Move to new generic scheme

DESCRIPTION

@@ -35,7 +35,8 @@ Suggests:
     covr,
     knitr,
     rmarkdown,
-    testthat (>= 3.0.0)
+    testthat (>= 3.0.0),
+    xgboost
 Config/Needs/website: 
     tidyverse/tidytemplate
 Config/testthat/edition: 3

NAMESPACE

@@ -4,29 +4,40 @@ S3method(format,vetiver_endpoint)
 S3method(format,vetiver_model)
 S3method(handler_predict,default)
 S3method(handler_predict,lm)
+S3method(handler_predict,xgb.Booster)
 S3method(handler_startup,default)
+S3method(handler_startup,xgb.Booster)
 S3method(predict,vetiver_endpoint)
 S3method(print,vetiver_endpoint)
 S3method(print,vetiver_model)
-S3method(vetiver_model,default)
-S3method(vetiver_model,lm)
-S3method(vetiver_slice_zero,default)
-S3method(vetiver_slice_zero,lm)
+S3method(vetiver_create_description,default)
+S3method(vetiver_create_description,lm)
+S3method(vetiver_create_description,xgb.Booster)
+S3method(vetiver_create_meta,default)
+S3method(vetiver_create_meta,xgb.Booster)
+S3method(vetiver_prepare_model,default)
+S3method(vetiver_prepare_model,lm)
+S3method(vetiver_ptype,default)
+S3method(vetiver_ptype,lm)
+S3method(vetiver_ptype,xgb.Booster)
 export(api_spec)
 export(attach_pkgs)
 export(handler_predict)
 export(handler_startup)
 export(load_pkgs)
 export(map_request_body)
 export(new_vetiver_model)
+export(vetiver_create_description)
+export(vetiver_create_meta)
 export(vetiver_create_ptype)
 export(vetiver_endpoint)
 export(vetiver_meta)
 export(vetiver_model)
 export(vetiver_pin_read)
 export(vetiver_pin_write)
 export(vetiver_pr_predict)
-export(vetiver_slice_zero)
+export(vetiver_prepare_model)
+export(vetiver_ptype)
 export(vetiver_type_convert)
 export(vetiver_write_plumber)
 import(purrr)

R/attach-pkgs.R

@@ -1,5 +1,6 @@
 #' Fully attach or load packages for making model predictions
 #'
+#' These are developer-facing functions, useful for supporting new model types.
 #' Some models require one or more R packages to be fully attached to make
 #' predictions, and some require only that the namespace of one or more R
 #' packages is loaded.

R/pr-handlers.R → R/handlers.R

@@ -1,5 +1,6 @@
 #' Model handler functions for API endpoint
 #'
+#' These are developer-facing functions, useful for supporting new model types.
 #' Each model supported by `vetiver_model()` uses two handler functions
 #' in [vetiver_pr_predict()]:
 #' - The `handler_startup` function executes when the API starts. Use this
@@ -17,52 +18,32 @@
 #' @examples
 #'
 #' cars_lm <- lm(mpg ~ ., data = mtcars)
-#' v <- vetiver_model(cars_lm, "cars_linear", pins::board_temp())
+#' v <- vetiver_model(cars_lm, "cars_linear")
 #' handler_startup(v)
 #' handler_predict(v)
 #'
 #' @return A `handler_startup` function should return invisibly, while a
 #' `handler_predict` function should return a function with the signature
 #' `function(req)`.
-#' @rdname handler_predict
+#' @rdname handler_startup
 #' @export
-handler_startup <- function(vetiver_model, ...)
+handler_startup <- function(vetiver_model)
     UseMethod("handler_startup", vetiver_model$model)
 
-#' @rdname handler_predict
+#' @rdname handler_startup
 #' @export
-handler_startup.default <- function(vetiver_model, ...) invisible(NULL)
+handler_startup.default <- function(vetiver_model) invisible(NULL)
 
-#' @rdname handler_predict
+#' @rdname handler_startup
 #' @export
 handler_predict <- function(vetiver_model, ...)
     UseMethod("handler_predict", vetiver_model$model)
 
-#' @rdname handler_predict
+#' @rdname handler_startup
 #' @export
 handler_predict.default <- function(vetiver_model, ...)
     abort("There is no method available to build a prediction handler for `x`.")
 
-
-#' @rdname handler_predict
-#' @export
-handler_predict.lm <- function(vetiver_model, ...) {
-
-    ptype <- vetiver_model$ptype
-
-    function(req) {
-        newdata <- req$body
-        if (!is_null(ptype)) {
-            newdata <- vetiver_type_convert(newdata, ptype)
-            newdata <- hardhat::scream(newdata, ptype)
-        }
-        ret <- predict(vetiver_model$model, newdata = newdata, ...)
-        list(.pred = ret)
-    }
-
-}
-
-
 #' Convert new data at prediction time using input data prototype
 #'
 #' This is a developer-facing function, useful for supporting new model types.

R/lm.R

@@ -0,0 +1,37 @@
+#' @rdname vetiver_create_description
+#' @export
+vetiver_create_description.lm <- function(model) {
+    "An OLS linear regression model"
+}
+
+#' @rdname vetiver_create_description
+#' @export
+vetiver_prepare_model.lm <- function(model) {
+    butcher::butcher(model)
+}
+
+#' @rdname vetiver_create_ptype
+#' @export
+vetiver_ptype.lm <- function(model, ...) {
+    pred_names <- attr(model$terms, "term.labels")
+    ptype <- vctrs::vec_ptype(model$model[pred_names])
+    tibble::as_tibble(ptype)
+}
+
+#' @rdname handler_startup
+#' @export
+handler_predict.lm <- function(vetiver_model, ...) {
+
+    ptype <- vetiver_model$ptype
+
+    function(req) {
+        newdata <- req$body
+        if (!is_null(ptype)) {
+            newdata <- vetiver_type_convert(newdata, ptype)
+            newdata <- hardhat::scream(newdata, ptype)
+        }
+        ret <- predict(vetiver_model$model, newdata = newdata, ...)
+        list(.pred = ret)
+    }
+
+}

R/meta.R

@@ -0,0 +1,45 @@
+#' Metadata constructors for `vetiver_model()` object
+#'
+#' These are developer-facing functions, useful for supporting new model types.
+#' The metadata stored in a [vetiver_model()] object has four elements:
+#'
+#' - `$user`, the metadata supplied by the user
+#' - `$version`, the version of the pin (which can be `NULL` before pinning)
+#' - `$url`, the URL where the pin is located, if any
+#' - `$required_pkgs`, a character string of R packages required for prediction
+#'
+#' @inheritParams vetiver_model
+#' @param user Metadata supplied by the user
+#' @param version Version of the pin
+#' @param url URL for the pin, if any
+#' @param required_pkgs Character string of R packages required for prediction
+#'
+#' @return The `vetiver_meta()` constructor returns a list. The
+#' `vetiver_create_meta` function returns a `vetiver_meta()` list.
+#'
+#' @examples
+#' vetiver_meta()
+#'
+#' cars_lm <- lm(mpg ~ ., data = mtcars)
+#' vetiver_create_meta(cars_lm, list())
+#'
+#' @rdname vetiver_create_meta
+#' @export
+vetiver_meta <- function(user = list(), version = NULL,
+                         url = NULL, required_pkgs = NULL) {
+    list(user = user, version = version,
+         url = url, required_pkgs = required_pkgs)
+}
+
+
+#' @rdname vetiver_create_meta
+#' @export
+vetiver_create_meta <- function(model, metadata) {
+    UseMethod("vetiver_create_meta")
+}
+
+#' @rdname vetiver_create_meta
+#' @export
+vetiver_create_meta.default <- function(model, metadata) {
+    vetiver_meta(metadata)
+}

R/open-api-spec.R

@@ -12,6 +12,9 @@
 #' @return A list to be used within [plumber::pr_set_api_spec()]
 #' @export
 #'
+#' @details
+#' This is a developer-facing function, useful for supporting new model types.
+#'
 #' @examples
 #' map_request_body(vctrs::vec_slice(chickwts, 0))
 #'

R/pin-read-write.R

@@ -22,8 +22,8 @@
 #' model_board <- board_temp()
 #'
 #' cars_lm <- lm(mpg ~ ., data = mtcars)
-#' v <- vetiver_model(cars_lm, "cars_linear", model_board)
-#' vetiver_pin_write(v)
+#' v <- vetiver_model(cars_lm, "cars_linear")
+#' vetiver_pin_write(model_board, v)
 #' model_board
 #'
 #' vetiver_pin_read(model_board, "cars_linear")
@@ -32,9 +32,9 @@
 #' pin_versions(model_board, "cars_linear")
 #'
 #' @export
-vetiver_pin_write <- function(vetiver_model) {
+vetiver_pin_write <- function(board, vetiver_model) {
     pins::pin_write(
-        board = vetiver_model$board,
+        board = board,
         x = list(model = vetiver_model$model,
                  ptype = vetiver_model$ptype,
                  required_pkgs = vetiver_model$metadata$required_pkgs),
@@ -58,7 +58,6 @@ vetiver_pin_read <- function(board, name, version = NULL) {
     new_vetiver_model(
         model = pinned$model,
         model_name = name,
-        board = board,
         description = meta$description,
         metadata = vetiver_meta(
             user = meta$user,

R/pr-predict.R

@@ -19,12 +19,9 @@
 #' @return A Plumber router with the prediction endpoint added.
 #'
 #' @examples
-#' library(pins)
-#' model_board <- board_temp()
 #'
 #' cars_lm <- lm(mpg ~ ., data = mtcars)
-#' v <- vetiver_model(cars_lm, "cars_linear", model_board)
-#' vetiver_pin_write(v)
+#' v <- vetiver_model(cars_lm, "cars_linear")
 #'
 #' library(plumber)
 #' pr() %>% vetiver_pr_predict(v)

R/prepare.R

@@ -0,0 +1,51 @@
+#' Model constructor methods
+#'
+#' These are developer-facing functions, useful for supporting new model types.
+#' Each model supported by [`vetiver_model()`] uses four methods when the
+#' deployable object is created:
+#' - The `vetiver_create_description()` function generates a helpful description
+#' of the model based on its characteristics. This method is required.
+#' - The [vetiver_create_meta()] function creates the correct [vetiver_meta()]
+#' for the model. This is especially helpful for specifying which packages are
+#' needed for prediction. A model can use the default method here, which is
+#' to have no special metadata.
+#' - The [vetiver_ptype()] function finds an input data prototype from the
+#' training data (a zero-row slice) to use for checking at prediction time.
+#' This method is required.
+#' - The `vetiver_prepare_model()` function executes last. Use this function
+#' for tasks like checking if the model is trained and reducing the size of the
+#' model via [butcher::butcher()]. A model can use the default method here,
+#' which is to return the model without changes.
+#'
+#' @inheritParams vetiver_model
+#' @details These are four generics that use the class of `model` for dispatch.
+#'
+#' @examples
+#'
+#' cars_lm <- lm(mpg ~ ., data = mtcars)
+#' vetiver_create_description(cars_lm)
+#' vetiver_prepare_model(cars_lm)
+#'
+#' @rdname vetiver_create_description
+#' @export
+vetiver_create_description <- function(model) {
+    UseMethod("vetiver_create_description")
+}
+
+#' @rdname vetiver_create_description
+#' @export
+vetiver_create_description.default <- function(model) {
+    abort("There is no method available to create a description for `model`.")
+}
+
+#' @rdname vetiver_create_description
+#' @export
+vetiver_prepare_model <- function(model) {
+    UseMethod("vetiver_prepare_model")
+}
+
+#' @rdname vetiver_create_description
+#' @export
+vetiver_prepare_model.default <- function(model) {
+    model
+}

R/create-ptype.R → R/ptype.R

@@ -7,8 +7,8 @@
 #' A [vetiver_model()] object optionally stores an input data prototype for
 #' checking at prediction time.
 #'
-#' - The default for `save_ptype`, `TRUE`, finds a zero-row slice of the
-#' training data via [vetiver_slice_zero()].
+#' - The default for `save_ptype`, `TRUE`, finds an input data prototype (a
+#' zero-row slice of the training data) via [vetiver_ptype()].
 #' - `save_ptype = FALSE` opts out of storing any input data prototype.
 #' - You may pass your own data to `save_ptype`, but be sure to check that it
 #' has the same structure as your training data, perhaps with
@@ -26,15 +26,15 @@
 #' vetiver_create_ptype(cars_lm, TRUE)
 #'
 #' ## calls the right method for `model` via:
-#' vetiver_slice_zero(cars_lm)
+#' vetiver_ptype(cars_lm)
 #'
 #' ## can also turn off `ptype`
 #' vetiver_create_ptype(cars_lm, FALSE)
 #'
 #' @export
 vetiver_create_ptype <- function(model, save_ptype, ...) {
     if (isTRUE(save_ptype)) {
-        ptype <- vetiver_slice_zero(model, ...)
+        ptype <- vetiver_ptype(model, ...)
     } else if (isFALSE(save_ptype)) {
         ptype <- NULL
     } else if (rlang::inherits_any(save_ptype, "data.frame")) {
@@ -47,23 +47,16 @@ vetiver_create_ptype <- function(model, save_ptype, ...) {
 
 #' @rdname vetiver_create_ptype
 #' @export
-vetiver_slice_zero <- function(model, ...) {
-    UseMethod("vetiver_slice_zero")
+vetiver_ptype <- function(model, ...) {
+    UseMethod("vetiver_ptype")
 }
 
 #' @rdname vetiver_create_ptype
 #' @export
-vetiver_slice_zero.default <- function(model, ...) {
+vetiver_ptype.default <- function(model, ...) {
     abort("There is no method available to create a 0-row input data prototype for `model`.")
 }
 
-#' @rdname vetiver_create_ptype
-#' @export
-vetiver_slice_zero.lm <- function(model, ...) {
-    pred_names <- attr(model$terms, "term.labels")
-    ptype <- vctrs::vec_ptype(model$model[pred_names])
-    tibble::as_tibble(ptype)
-}