Merge pull request #42 from curso-r/bugfix/CI

install pandoc in CI

.github/workflows/R-CMD-check.yaml

@@ -11,18 +11,30 @@ jobs:
     runs-on: windows-latest
     steps:
       - uses: actions/checkout@v2
+
+      - uses: r-lib/actions/setup-pandoc@v1
+
       - uses: r-lib/actions/setup-r@master
+
       - name: Install remotes
         run: install.packages(c("remotes", "rcmdcheck"))
         shell: Rscript {0}
-      - name: Install catboost
+
+      - name: Install additional dependencies
         run: |
-          remotes::install_url("https://github.com/catboost/catboost/releases/download/v0.23/catboost-R-Windows-0.23.tgz", INSTALL_opts = c("--no-multiarch"))
+          remotes::install_deps(dependencies = TRUE, INSTALL_opts = c("--no-multiarch"))
         shell: Rscript {0}
-      - name: Install dependencies
+
+      - name: Install catboost
         run: |
-          remotes::install_deps(dependencies = TRUE, INSTALL_opts = c("--no-multiarch"))
+          remotes::install_url("https://github.com/catboost/catboost/releases/download/v0.26/catboost-R-Windows-0.26.tgz", INSTALL_opts = c("--no-multiarch"))
         shell: Rscript {0}
+
       - name: Check
-        run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--no-multiarch"), error_on = "error")
+        run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--no-multiarch"), error_on = "error", check_dir = "check")
         shell: Rscript {0}
+
+      - name: Show testthat output
+        if: always()
+        run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true
+        shell: bash

DESCRIPTION

@@ -23,7 +23,9 @@ Suggests:
     lightgbm,
     knitr,
     rmarkdown,
-    readr
+    readr,
+    glue,
+    scales
 RoxygenNote: 7.1.1
 Imports: 
     rlang,

R/catboost.R

@@ -191,7 +191,7 @@ add_boost_tree_catboost <- function() {
     eng = "catboost",
     parsnip = "sample_prop",
     original = "subsample",
-    func = list(pkg = "dials", fun = "sample_size"),
+    func = list(pkg = "dials", fun = "sample_prop"),
     has_submodel = FALSE
   )
 }

R/lightgbm.R

@@ -168,7 +168,7 @@ add_boost_tree_lightgbm <- function() {
     eng = "lightgbm",
     parsnip = "sample_prop",
     original = "bagging_fraction",
-    func = list(pkg = "dials", fun = "sample_size"),
+    func = list(pkg = "dials", fun = "sample_prop"),
     has_submodel = FALSE
   )
 }
@@ -272,7 +272,7 @@ train_lightgbm <- function(x, y, max_depth = 17, num_iterations = 10, learning_r
     data = prepare_df_lgbm(x),
     label = y,
     categorical_feature = categorical_columns(x),
-    feature_pre_filter = FALSE
+    params = list(feature_pre_filter = FALSE)
   )
 
   main_args <- list(
@@ -345,7 +345,8 @@ predict_lightgbm_classification_raw <- function(object, new_data, ...) {
 #' @export
 predict_lightgbm_regression_numeric <- function(object, new_data, ...) {
   # train_colnames <- object$fit$.__enclos_env__$private$train_set$get_colnames()
-  p <- stats::predict(object$fit, prepare_df_lgbm(new_data), reshape = TRUE, predict_disable_shape_check=TRUE, ...)
+  p <- stats::predict(object$fit, prepare_df_lgbm(new_data), reshape = TRUE,
+                      params = list(predict_disable_shape_check=TRUE), ...)
   p
 }
 

R/train.R

@@ -1,7 +1,18 @@
+
 .onLoad <- function(libname, pkgname){
-  add_decision_tree_tree()
-  add_boost_tree_catboost()
-  add_boost_tree_lightgbm()
+
+  if (!"lightgbm" %in% parsnip::get_model_env()$boost_tree$engine) {
+    add_boost_tree_lightgbm()
+  }
+
+  if (!"catboost" %in% parsnip::get_model_env()$boost_tree$engine) {
+    add_boost_tree_catboost()
+  }
+
+  if (!"tree" %in% parsnip::get_model_env()$decision_tree$engine) {
+    add_decision_tree_tree()
+  }
+
 }
 
 

R/tree.R

@@ -12,6 +12,18 @@ add_decision_tree_tree <- function() {
 
   parsnip::set_dependency("decision_tree", eng = "tree", pkg = "tree")
 
+  parsnip::set_encoding(
+    model = "decision_tree",
+    eng = "tree",
+    mode = "regression",
+    options = list(
+      predictor_indicators = "none",
+      compute_intercept = FALSE,
+      remove_intercept = FALSE,
+      allow_sparse_x = FALSE
+    )
+  )
+
   parsnip::set_fit(
     model = "decision_tree",
     eng = "tree",

tests/testthat/helper-model.R

@@ -5,7 +5,7 @@ mtcars_class_binary$vs <- as.factor(mtcars$vs)
 
 expect_all_modes_works <- function(model, engine) {
   if(engine == "lightgbm") {
-    model <- parsnip::set_engine(model, engine)
+    model <- parsnip::set_engine(model, engine, verbose = -1L)
   } else {
     model <- parsnip::set_engine(model, engine)
   }
@@ -92,6 +92,9 @@ expect_categorical_vars_works <- function(model) {
 }
 
 expect_can_tune_boost_tree <- function(model) {
+
+  mtcars <- dplyr::sample_n(mtcars, size = 500, replace = TRUE)
+
   mtcars$cyl <- factor(mtcars$cyl)
   mtcars$vs <- factor(mtcars$vs)
 

tests/testthat/test-catboost.R

@@ -16,8 +16,8 @@ test_that('catboost alternate objective', {
   info <- catboost::catboost.get_model_params(cat_fit$fit)
 
   expect_equal(info$loss_function$type, "Huber")
-  expect_equal(info$loss_function$params[1], "delta")
-  expect_equal(info$loss_function$params[2], "1")
+  expect_true(grepl("delta", info$loss_function$params[1]))
+  expect_equal(info$loss_function$params[[2]], "1")
 })
 
 test_that("catboost with tune", {

tests/testthat/test-lightgbm.R

@@ -50,7 +50,7 @@ test_that("lightgbm mtry", {
 
 test_that("lightgbm trees", {
 
-  hyperparameters <- data.frame(trees = c(1, 20, 300))
+  hyperparameters <- data.frame(trees = c(1, 20, 50))
   for(i in 1:nrow(hyperparameters)) {
     model <- parsnip::boost_tree(trees = hyperparameters$trees[i], min_n = 1)
     expect_all_modes_works(model, 'lightgbm')

vignettes/.gitignore

@@ -1,2 +1,6 @@
 *.html
 *.R
+working-with-lightgbm-catboost_cache
+threading-forking-benchmark_cache
+parallel-processing_cache
+catboost_info

vignettes/working-with-lightgbm-catboost.Rmd

@@ -13,15 +13,16 @@ knitr::opts_chunk$set(
   comment = "#>",
   eval = FALSE,
   warning = FALSE,
-  message = FALSE
+  message = FALSE,
+  eval = FALSE
 )
 ```
 
 ```{r setup}
 library(tidymodels)
 library(treesnip)
 data("diamonds", package = "ggplot2")
-
+diamonds <- diamonds %>% sample_n(1000)
 # vfold resamples
 diamonds_splits <- vfold_cv(diamonds, v = 5)
 ```