Merge pull request #75 from tidymodels/add-glm

Add vetiver support for `glm()`

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

@@ -40,28 +40,17 @@ jobs:
     steps:
       - uses: actions/checkout@v2
 
-      - uses: r-lib/actions/setup-pandoc@v1
+      - uses: r-lib/actions/setup-pandoc@v2
 
-      - uses: r-lib/actions/setup-r@v1
+      - uses: r-lib/actions/setup-r@v2
         with:
           r-version: ${{ matrix.config.r }}
           http-user-agent: ${{ matrix.config.http-user-agent }}
           use-public-rspm: true
 
-      - uses: r-lib/actions/setup-r-dependencies@v1
+      - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: rcmdcheck
+          extra-packages: any::rcmdcheck
+          needs: check
 
-      - uses: r-lib/actions/check-r-package@v1
-
-      - name: Show testthat output
-        if: always()
-        run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true
-        shell: bash
-
-      - name: Upload check results
-        if: failure()
-        uses: actions/upload-artifact@main
-        with:
-          name: ${{ runner.os }}-r${{ matrix.config.r }}-results
-          path: check
+      - uses: r-lib/actions/check-r-package@v2

NAMESPACE

@@ -8,6 +8,7 @@ S3method(glue_spec_summary,data.frame)
 S3method(glue_spec_summary,default)
 S3method(handler_predict,Learner)
 S3method(handler_predict,default)
+S3method(handler_predict,glm)
 S3method(handler_predict,lm)
 S3method(handler_predict,train)
 S3method(handler_predict,workflow)
@@ -26,6 +27,7 @@ S3method(print,vetiver_endpoint)
 S3method(print,vetiver_model)
 S3method(vetiver_create_description,Learner)
 S3method(vetiver_create_description,default)
+S3method(vetiver_create_description,glm)
 S3method(vetiver_create_description,lm)
 S3method(vetiver_create_description,train)
 S3method(vetiver_create_description,workflow)
@@ -37,11 +39,13 @@ S3method(vetiver_create_meta,workflow)
 S3method(vetiver_create_meta,xgb.Booster)
 S3method(vetiver_prepare_model,Learner)
 S3method(vetiver_prepare_model,default)
+S3method(vetiver_prepare_model,glm)
 S3method(vetiver_prepare_model,lm)
 S3method(vetiver_prepare_model,train)
 S3method(vetiver_prepare_model,workflow)
 S3method(vetiver_ptype,Learner)
 S3method(vetiver_ptype,default)
+S3method(vetiver_ptype,glm)
 S3method(vetiver_ptype,lm)
 S3method(vetiver_ptype,train)
 S3method(vetiver_ptype,workflow)

NEWS.md

@@ -2,6 +2,8 @@
 
 * Generate Dockerfiles to deploy model (#71).
 
+* Added support for glm (#75).
+
 # vetiver 0.1.1
 
 * Added support for tidymodels (#51), caret (#52), and mlr3 (#56).

R/glm.R

@@ -0,0 +1,23 @@
+#' @rdname vetiver_create_description
+#' @export
+vetiver_create_description.glm <- function(model) {
+    glue("A generalized linear model ({model$family$family} family, {model$family$link} link)")
+}
+
+#' @rdname vetiver_create_description
+#' @export
+vetiver_prepare_model.glm <- function(model) {
+    butcher::butcher(model)
+}
+
+#' @rdname vetiver_create_ptype
+#' @export
+vetiver_ptype.glm <- function(model, ...) {
+    vetiver_ptype.lm(model, ...)
+}
+
+#' @rdname handler_startup
+#' @export
+handler_predict.glm <- function(vetiver_model, ...) {
+    handler_predict.lm(vetiver_model, ...)
+}

README.Rmd

@@ -32,7 +32,7 @@ You can use vetiver with:
 - [caret](https://topepo.github.io/caret/)
 - [mlr3](https://mlr3.mlr-org.com/)
 - [XGBoost](https://xgboost.readthedocs.io/en/latest/R-package/)
-- [`lm()`](https://stat.ethz.ch/R-manual/R-patched/library/stats/html/lm.html)
+- [`lm()`](https://stat.ethz.ch/R-manual/R-patched/library/stats/html/lm.html) and [`glm()`](https://stat.ethz.ch/R-manual/R-patched/library/stats/html/glm.html)
 
 ## Installation
 

README.md

@@ -30,6 +30,8 @@ You can use vetiver with:
 -   [mlr3](https://mlr3.mlr-org.com/)
 -   [XGBoost](https://xgboost.readthedocs.io/en/latest/R-package/)
 -   [`lm()`](https://stat.ethz.ch/R-manual/R-patched/library/stats/html/lm.html)
+    and
+    [`glm()`](https://stat.ethz.ch/R-manual/R-patched/library/stats/html/glm.html)
 
 ## Installation
 

tests/testthat/_snaps/glm.md

@@ -0,0 +1,28 @@
+# can print glm model
+
+    Code
+      v
+    Output
+      
+      -- cars_glm - <butchered_glm> model for deployment 
+      A generalized linear model (gaussian family, identity link) using 10 features
+
+# create plumber.R for xgboost
+
+    Code
+      cat(readr::read_lines(tmp), sep = "\n")
+    Output
+      # Generated by the vetiver package; edit with care
+      
+      library(pins)
+      library(plumber)
+      library(rapidoc)
+      library(vetiver)
+      b <- board_folder(path = "/tmp/test")
+      v <- vetiver_pin_read(b, "cars_glm")
+      
+      #* @plumber
+      function(pr) {
+          pr %>% vetiver_pr_predict(v)
+      }
+

tests/testthat/test-glm.R

@@ -0,0 +1,64 @@
+library(pins)
+library(plumber)
+
+mtcars_glm <- glm(mpg ~ ., data = mtcars)
+v <- vetiver_model(mtcars_glm, "cars_glm")
+
+test_that("can print glm model", {
+    expect_snapshot(v)
+})
+
+test_that("can predict glm model", {
+    preds <- predict(v, mtcars)
+    expect_type(preds, "double")
+    expect_equal(mean(preds), 20.1, tolerance = 0.1)
+})
+
+test_that("can pin a glm model", {
+    b <- board_temp()
+    vetiver_pin_write(b, v)
+    pinned <- pin_read(b, "cars_glm")
+    expect_equal(
+        pinned,
+        list(
+            model = butcher::butcher(mtcars_glm),
+            ptype = vctrs::vec_slice(tibble::as_tibble(mtcars[,2:11]), 0),
+            required_pkgs = NULL
+        ),
+        ignore_function_env = TRUE,
+        ignore_formula_env = TRUE
+    )
+})
+
+test_that("default endpoint for glm", {
+    p <- pr() %>% vetiver_pr_predict(v)
+    expect_equal(names(p$routes), c("ping", "predict"))
+    expect_equal(map_chr(p$routes, "verbs"),
+                 c(ping = "GET", predict = "POST"))
+})
+
+test_that("default OpenAPI spec", {
+    v$metadata <- list(url = "potatoes")
+    p <- pr() %>% vetiver_pr_predict(v)
+    car_spec <- p$getApiSpec()
+    expect_equal(car_spec$info$description,
+                 "A generalized linear model (gaussian family, identity link)")
+    post_spec <- car_spec$paths$`/predict`$post
+    expect_equal(names(post_spec), c("summary", "requestBody", "responses"))
+    expect_equal(as.character(post_spec$summary),
+                 "Return predictions from model using 10 features")
+    get_spec <- car_spec$paths$`/pin-url`$get
+    expect_equal(as.character(get_spec$summary),
+                 "Get URL of pinned vetiver model")
+
+})
+
+test_that("create plumber.R for xgboost", {
+    skip_on_cran()
+    b <- board_folder(path = "/tmp/test")
+    vetiver_pin_write(b, v)
+    tmp <- tempfile()
+    vetiver_write_plumber(b, "cars_glm", file = tmp)
+    expect_snapshot(cat(readr::read_lines(tmp), sep = "\n"))
+})
+

tests/testthat/test-tidymodels.R

@@ -32,7 +32,7 @@ test_that("can pin a tidymodels model", {
     vetiver_pin_write(b, v)
     pinned <- pin_read(b, "cars_wf")
     expect_equal(
-        pin_read(b, "cars_wf"),
+        pinned,
         list(
             model = butcher::butcher(mtcars_wf),
             ptype = vctrs::vec_slice(tibble::as_tibble(mtcars[,2:11]), 0),