[CI] Improve R linter script (#5944)

* [CI] Move lint to a separate script

* [CI] Improved lintr launcher

* Add lintr as a separate action

* Add custom parsing logic to print out logs

* Fix lintr issues in demos

* Run R demos

* Fix CRAN checks

* Install XGBoost into R env before running lintr

* Install devtools (needed to run demos)

R-package/tests/run_lint.R

@@ -0,0 +1,71 @@
+library(lintr)
+library(crayon)
+
+my_linters <- list(
+  absolute_path_linter = lintr::absolute_path_linter,
+  assignment_linter = lintr::assignment_linter,
+  closed_curly_linter = lintr::closed_curly_linter,
+  commas_linter = lintr::commas_linter,
+  # commented_code_linter = lintr::commented_code_linter,
+  infix_spaces_linter = lintr::infix_spaces_linter,
+  line_length_linter = lintr::line_length_linter,
+  no_tab_linter = lintr::no_tab_linter,
+  object_usage_linter = lintr::object_usage_linter,
+  # snake_case_linter = lintr::snake_case_linter,
+  # multiple_dots_linter = lintr::multiple_dots_linter,
+  object_length_linter = lintr::object_length_linter,
+  open_curly_linter = lintr::open_curly_linter,
+  # single_quotes_linter = lintr::single_quotes_linter,
+  spaces_inside_linter = lintr::spaces_inside_linter,
+  spaces_left_parentheses_linter = lintr::spaces_left_parentheses_linter,
+  trailing_blank_lines_linter = lintr::trailing_blank_lines_linter,
+  trailing_whitespace_linter = lintr::trailing_whitespace_linter,
+  true_false = lintr::T_and_F_symbol_linter
+)
+
+results <- lapply(
+  list.files(path = '.', pattern = '\\.[Rr]$', recursive = TRUE),
+  function (r_file) {
+    cat(sprintf("Processing %s ...\n", r_file))
+    list(r_file = r_file,
+         output = lintr::lint(filename = r_file, linters = my_linters))
+  })
+num_issue <- Reduce(sum, lapply(results, function (e) length(e$output)))
+
+lint2str <- function(lint_entry) {
+  color <- function(type) {
+    switch(type,
+      "warning" = crayon::magenta,
+      "error" = crayon::red,
+      "style" = crayon::blue,
+      crayon::bold
+    )
+  }
+
+  paste0(
+    lapply(lint_entry$output,
+      function (lint_line) {
+        paste0(
+          crayon::bold(lint_entry$r_file, ":",
+          as.character(lint_line$line_number), ":",
+          as.character(lint_line$column_number), ": ", sep = ""),
+          color(lint_line$type)(lint_line$type, ": ", sep = ""),
+          crayon::bold(lint_line$message), "\n",
+          lint_line$line, "\n",
+          lintr:::highlight_string(lint_line$message, lint_line$column_number, lint_line$ranges),
+          "\n",
+          collapse = "")
+      }),
+    collapse = "")
+}
+
+if (num_issue > 0) {
+  cat(sprintf('R linters found %d issues:\n', num_issue))
+  for (entry in results) {
+    if (length(entry$output)) {
+      cat(paste0('**** ', crayon::bold(entry$r_file), '\n'))
+      cat(paste0(lint2str(entry), collapse = ''))
+    }
+  }
+  quit(save = 'no', status = 1)  # Signal error to parent shell
+}

R-package/tests/testthat/test_lint.R

@@ -1,26 +0,0 @@
-context("Code is of high quality and lint free")
-test_that("Code Lint", {
-  skip_on_cran()
-  my_linters <- list(
-    absolute_path_linter = lintr::absolute_path_linter,
-    assignment_linter = lintr::assignment_linter,
-    closed_curly_linter = lintr::closed_curly_linter,
-    commas_linter = lintr::commas_linter,
-    # commented_code_linter = lintr::commented_code_linter,
-    infix_spaces_linter = lintr::infix_spaces_linter,
-    line_length_linter = lintr::line_length_linter,
-    no_tab_linter = lintr::no_tab_linter,
-    object_usage_linter = lintr::object_usage_linter,
-    # snake_case_linter = lintr::snake_case_linter,
-    # multiple_dots_linter = lintr::multiple_dots_linter,
-    object_length_linter = lintr::object_length_linter,
-    open_curly_linter = lintr::open_curly_linter,
-    # single_quotes_linter = lintr::single_quotes_linter,
-    spaces_inside_linter = lintr::spaces_inside_linter,
-    spaces_left_parentheses_linter = lintr::spaces_left_parentheses_linter,
-    trailing_blank_lines_linter = lintr::trailing_blank_lines_linter,
-    trailing_whitespace_linter = lintr::trailing_whitespace_linter,
-    true_false = lintr::T_and_F_symbol_linter
-  )
-  lintr::expect_lint_free(linters = my_linters) # uncomment this if you want to check code quality
-})

R-package/tests/testthat/test_model_compatibility.R

@@ -7,8 +7,8 @@ context("Models from previous versions of XGBoost can be loaded")
 metadata <- model_generator_metadata()
 
 run_model_param_check <- function (config) {
-  expect_equal(config$learner$learner_model_param$num_feature, '4')
-  expect_equal(config$learner$learner_train_param$booster, 'gbtree')
+  testthat::expect_equal(config$learner$learner_model_param$num_feature, '4')
+  testthat::expect_equal(config$learner$learner_train_param$booster, 'gbtree')
 }
 
 get_num_tree <- function (booster) {
@@ -27,22 +27,24 @@ run_booster_check <- function (booster, name) {
   config <- jsonlite::fromJSON(xgb.config(booster))
   run_model_param_check(config)
   if (name == 'cls') {
-    expect_equal(get_num_tree(booster), metadata$kForests * metadata$kRounds * metadata$kClasses)
-    expect_equal(as.numeric(config$learner$learner_model_param$base_score), 0.5)
-    expect_equal(config$learner$learner_train_param$objective, 'multi:softmax')
-    expect_equal(as.numeric(config$learner$learner_model_param$num_class), metadata$kClasses)
+    testthat::expect_equal(get_num_tree(booster),
+                           metadata$kForests * metadata$kRounds * metadata$kClasses)
+    testthat::expect_equal(as.numeric(config$learner$learner_model_param$base_score), 0.5)
+    testthat::expect_equal(config$learner$learner_train_param$objective, 'multi:softmax')
+    testthat::expect_equal(as.numeric(config$learner$learner_model_param$num_class),
+                           metadata$kClasses)
   } else if (name == 'logit') {
-    expect_equal(get_num_tree(booster), metadata$kForests * metadata$kRounds)
-    expect_equal(as.numeric(config$learner$learner_model_param$num_class), 0)
-    expect_equal(config$learner$learner_train_param$objective, 'binary:logistic')
+    testthat::expect_equal(get_num_tree(booster), metadata$kForests * metadata$kRounds)
+    testthat::expect_equal(as.numeric(config$learner$learner_model_param$num_class), 0)
+    testthat::expect_equal(config$learner$learner_train_param$objective, 'binary:logistic')
   } else if (name == 'ltr') {
-    expect_equal(get_num_tree(booster), metadata$kForests * metadata$kRounds)
-    expect_equal(config$learner$learner_train_param$objective, 'rank:ndcg')
+    testthat::expect_equal(get_num_tree(booster), metadata$kForests * metadata$kRounds)
+    testthat::expect_equal(config$learner$learner_train_param$objective, 'rank:ndcg')
   } else {
-    expect_equal(name, 'reg')
-    expect_equal(get_num_tree(booster), metadata$kForests * metadata$kRounds)
-    expect_equal(as.numeric(config$learner$learner_model_param$base_score), 0.5)
-    expect_equal(config$learner$learner_train_param$objective, 'reg:squarederror')
+    testthat::expect_equal(name, 'reg')
+    testthat::expect_equal(get_num_tree(booster), metadata$kForests * metadata$kRounds)
+    testthat::expect_equal(as.numeric(config$learner$learner_model_param$base_score), 0.5)
+    testthat::expect_equal(config$learner$learner_train_param$objective, 'reg:squarederror')
   }
 }
 
@@ -73,5 +75,4 @@ test_that("Models from previous versions of XGBoost can be loaded", {
     predict(booster, newdata = pred_data)
     run_booster_check(booster, name)
   })
-  expect_true(TRUE)
 })