R/write-plumber.R

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

#' Write a deployable Plumber file for a vetiver model
#'
#' Use `vetiver_write_plumber()` to create a `plumber.R` file for a
#' [vetiver_model()] that has been versioned and stored via
#' [vetiver_pin_write()].
#'
#' @inheritParams pins::pin_read
#' @inheritParams vetiver_model
#' @param ... Other arguments passed to [vetiver_api()] such as the endpoint
#' `path` or prediction `type`.
#' @param file A path to write the Plumber file. Defaults to `plumber.R` in the
#' working directory. See [plumber::plumb()] for naming precedence rules.
#' @param rsconnect Create a Plumber file with features needed for [Posit
#' Connect](https://posit.co/products/enterprise/connect/)? Defaults to `TRUE`.
#' @param additional_pkgs Any additional R packages that need to be **attached**
#' via [library()] to run your API, as a character vector.
#'
#' @details
#' By default, this function will find and use the latest version of your
#' vetiver model; the model API (when deployed) will be linked to that specific
#' version. You can override this default behavior by choosing a specific
#' `version`.
#'
#' @return
#' The content of the `plumber.R` file, invisibly.
#'
#' @export
#'
#' @examplesIf rlang::is_installed("plumber")
#' library(pins)
#' tmp <- tempfile()
#' b <- board_temp(versioned = TRUE)
#' cars_lm <- lm(mpg ~ ., data = mtcars)
#' v <- vetiver_model(cars_lm, "cars_linear")
#' vetiver_pin_write(b, v)
#'
#' vetiver_write_plumber(b, "cars_linear", file = tmp)
#'
vetiver_write_plumber <- function(board, name, version = NULL,
                                  ...,
                                  file = "plumber.R",
                                  rsconnect = TRUE,
                                  additional_pkgs = character(0)) {

    rlang::check_installed("plumber")
    plumber_dots <- rlang::list2(...)

    if (board$versioned) {
        if (is_null(version)) {
            version <- pins::pin_versions(board, name)
            version <- choose_version(version)
        }
        pin_read <- glue('v <- vetiver_pin_read(b, "{name}", version = "{version}")')
        v <- vetiver_pin_read(board, name, version = version)
    } else {
        pin_read <- glue('v <- vetiver_pin_read(b, "{name}")')
        v <- vetiver_pin_read(board, name)
    }

    write_extra_requirements(v$model, file)

    infra_pkgs <- sort(c(infra_pkgs, additional_pkgs))
    load_infra_pkgs <- glue_collapse(glue("library({infra_pkgs})"), sep = "\n")
    load_required_pkgs <- glue_required_pkgs(v$metadata$required_pkgs, rsconnect)

    ## rlang::expr_deparse won't work for board_url, but
    ## base deparse won't work for S3 and other complex boards:
    if (inherits(board, "pins_board_url")) {
        board <- deparse(pins::board_deparse(board))
    } else {
        board <- rlang::expr_deparse(pins::board_deparse(board))
    }
    board <- glue('b <- {board}')

    if (rlang::is_empty(plumber_dots)) {
        pr_predict <- "pr %>% vetiver_api(v)"
    } else {
        pr_predict <- expr(pr %>% vetiver_api(v, !!!plumber_dots))
        pr_predict <- expr_deparse(pr_predict)
    }

    plumber <- glue("\n
         #* @plumber
         function(pr) {{
             {pr_predict}
         }}
         ")

    ret <- compact(list(
        "# Generated by the vetiver package; edit with care\n",
        load_infra_pkgs,
        load_required_pkgs,
        board,
        pin_read,
        plumber
    ))
    readr::write_lines(ret, file = file)
}

infra_pkgs <- c("pins", "plumber", "rapidoc", "vetiver")


glue_required_pkgs <- function(required_pkgs, rsconnect) {
    if (!is_null(required_pkgs) && rsconnect) {
        required_pkgs <- sort(required_pkgs)
        required_pkgs <- glue_collapse(glue("    library({required_pkgs})"),
                                       sep = "\n")
        load_required_pkgs <- glue("\n
            # Packages needed to generate model predictions
            if (FALSE) {{
            {required_pkgs}
            }}
            ")
        return(load_required_pkgs)
    }
    NULL
}

choose_version <- function(df) {
    if (has_name(df, "active")) {
        version <- vec_slice(df, df$active)
    } else if (has_name(df, "created")) {
        idx <- head(order(df$created, decreasing = TRUE), 1)
        version <- vec_slice(df, idx)
    } else {
        version <- vec_slice(df, 1)
        warn(
            c("Pinned vetiver model has no active version and no datetime on versions",
              "Do you need to check your pinned model?",
              glue('Using version {version[["version"]]}'))
        )
    }
    version[["version"]]
}

write_extra_requirements <- function(model, file) {
    model <- bundle::unbundle(model)
    path_to_py_requirements <- vetiver_python_requirements(model)
    file_copy_requirements(path_to_py_requirements, file, "requirements.txt")
    path_to_renviron_requirements <- vetiver_renviron_requirements(model)
    file_copy_requirements(path_to_renviron_requirements, file, ".Renviron")
    TRUE
}

file_copy_requirements <- function(requirements, plumber_file, new_name) {
    if (!is.null(requirements)) {
        fs::file_copy(
            requirements,
            fs::path(fs::path_dir(plumber_file), new_name),
            overwrite = TRUE
        )
    }
    requirements
}

#' Use extra files required for deployment
#'
#' Create files required for deploying an app generated via
#' [vetiver_write_plumber()], such as a Python `requirements.txt` or an
#' `.Renviron`
#'
#' @inheritParams vetiver_model
#' @export
#' @keywords internal
vetiver_python_requirements <- function(model) {
    UseMethod("vetiver_python_requirements")
}

#' @rdname vetiver_python_requirements
#' @export
vetiver_python_requirements.default <- function(model) {
    NULL
}

#' @rdname vetiver_python_requirements
#' @export
vetiver_renviron_requirements <- function(model) {
    UseMethod("vetiver_renviron_requirements")
}

#' @rdname vetiver_python_requirements
#' @export
vetiver_renviron_requirements.default <- function(model) {
    NULL
}