R/pin-read-write.R

In tidymodels/vetiver: Version, Share, Deploy, and Monitor Models

#' Read and write a trained model to a board of models
#'
#' Use `vetiver_pin_write()` to pin a trained model to a board of models,
#' along with an input prototype for new data and other model metadata. Use
#' `vetiver_pin_read()` to retrieve that pinned object.
#'
#' @inheritParams pins::pin_read
#' @inheritParams vetiver_api
#' @param check_renv Use [renv](https://rstudio.github.io/renv/) to record the
#' packages used at training time with `vetiver_pin_write()` and check for
#' differences with `vetiver_pin_read()`. Defaults to `FALSE`.
#'
#' @details These functions read and write a [vetiver_model()] pin on the
#' specified `board` containing the model object itself and other elements
#' needed for prediction, such as the model's input data prototype or which
#' packages are needed at prediction time. You may use [pins::pin_read()] or
#' [pins::pin_meta()] to handle the pin, but `vetiver_pin_read()` returns a
#' [vetiver_model()] object ready for deployment.
#'
#' @return `vetiver_pin_read()` returns a [vetiver_model()]; `vetiver_pin_write()`
#' returns the name of the new pin, invisibly.
#'
#' @examples
#' library(pins)
#' model_board <- board_temp()
#'
#' cars_lm <- lm(mpg ~ ., data = mtcars)
#' v <- vetiver_model(cars_lm, "cars_linear")
#' vetiver_pin_write(model_board, v)
#' model_board
#'
#' vetiver_pin_read(model_board, "cars_linear")
#'
#' # can use `version` argument to read a specific version:
#' pin_versions(model_board, "cars_linear")
#' @examplesIf interactive() || identical(Sys.getenv("IN_PKGDOWN"), "true")
#' # can store an renv lockfile as part of the pin:
#' vetiver_pin_write(model_board, v, check_renv = TRUE)
#'
#' @export
vetiver_pin_write <- function(board, vetiver_model, ..., check_renv = FALSE) {

    renv_lock <- NULL

    if (check_renv) {
        pkgs <- c(vetiver_model$metadata$required_pkgs, "vetiver")
        renv_lock <-
            renv$snapshot(
                lockfile = NULL,
                packages = pkgs,
                prompt = FALSE,
                force = TRUE
            )
    }

    metadata <- list_modify(
        vetiver_model$metadata$user,
        required_pkgs = vetiver_model$metadata$required_pkgs,
        renv_lock = renv_lock
    )

    pins::pin_write(
        board = board,
        x = list(model = vetiver_model$model,
                 prototype = vetiver_model$prototype),
        name = vetiver_model$model_name,
        type = "rds",
        description = vetiver_model$description,
        metadata = metadata,
        versioned = vetiver_model$versioned,
        ...,
        force_identical_write = TRUE
    )

    rlang::inform(
        c("\nCreate a Model Card for your published model",
          "Model Cards provide a framework for transparent, responsible reporting",
          "Use the vetiver `.Rmd` template as a place to start"),
        class = "model_card_nudge",
        .frequency = "once",
        .frequency_id = "model_card_nudge"
    )
}

#' @rdname vetiver_pin_write
#' @export
vetiver_pin_read <- function(board, name, version = NULL, check_renv = FALSE) {

    pinned <- pins::pin_read(board = board, name = name, version = version)
    meta   <- pins::pin_meta(board = board, name = name, version = version)
    required_pkgs <- meta$user$required_pkgs %||% pinned$required_pkgs

    if (check_renv) {
        if (length(meta$user$renv_lock) > 0) {
            local_lockfile <-
                renv$snapshot(
                    lockfile = NULL,
                    packages = c(required_pkgs, "vetiver"),
                    prompt = FALSE,
                    force = TRUE
                )
            orig_lockfile <- structure(meta$user$renv_lock, class = "renv_lockfile")
            renv_report_actions(local_lockfile, orig_lockfile)
        } else {
            cli::cli_warn(c(
                "There is no lockfile stored with {.val {name}}:",
                "i" = "Use {.arg check_renv = TRUE} when you save your model to your board"
            ))
        }
    }

    meta$user <- list_modify(meta$user, required_pkgs = zap(), renv_lock = zap())
    if (is_empty(meta$user)) names(meta$user) <- NULL

    new_vetiver_model(
        model = pinned$model,
        model_name = name,
        description = meta$description,
        metadata = vetiver_meta(
            user = meta$user,
            version = meta$local$version,
            url = meta$local$url,
            required_pkgs = required_pkgs
        ),
        prototype = pinned$prototype %||% pinned$ptype,
        versioned = board$versioned
    )
}


renv_report_actions <- function(current, model) {
    withr::local_options(
        list(renv.pretty.print.emitter = function(text, ...) {cli::cli_inform(text)})
    )
    diff <- renv$renv_lockfile_diff_packages(current, model)

    if (renv$empty(diff))
        return(invisible(NULL))

    lhs <- renv$renv_records(current)
    rhs <- renv$renv_records(model)
    renv$renv_pretty_print_records_pair(
        "The following package(s) do not match your model:",
        lhs[names(lhs) %in% names(diff)],
        rhs[names(rhs) %in% names(diff)],
        "Consider installing the same versions that your model was trained with."
    )

}