R/prototype.R

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

#' Create a vetiver input data prototype
#'
#' Optionally find and return an input data prototype for a model.
#'
#' @details
#' These are developer-facing functions, useful for supporting new model types.
#' A [vetiver_model()] object optionally stores an input data prototype for
#' checking at prediction time.
#'
#' - The default for `save_prototype`, `TRUE`, finds an input data prototype (a
#' zero-row slice of the training data) via [vetiver_ptype()].
#' - `save_prototype = FALSE` opts out of storing any input data prototype.
#' - You may pass your own data to `save_prototype`, but be sure to check that it
#' has the same structure as your training data, perhaps with
#' [hardhat::scream()].
#'
#' @inheritParams vetiver_model
#'
#' @return A `vetiver_ptype` method returns a zero-row dataframe, and
#' `vetiver_create_ptype()` returns either such a zero-row dataframe, `NULL`,
#' or the dataframe passed to `save_prototype`.
#'
#' @examples
#'
#' cars_lm <- lm(mpg ~ cyl + disp, data = mtcars)
#'
#' vetiver_create_ptype(cars_lm, TRUE)
#'
#' ## calls the right method for `model` via:
#' vetiver_ptype(cars_lm)
#'
#' ## can also turn off prototype
#' vetiver_create_ptype(cars_lm, FALSE)
#' @examplesIf rlang::is_installed("ranger")
#' ## some models require that you pass in training features
#' cars_rf <- ranger::ranger(mpg ~ ., data = mtcars)
#' vetiver_ptype(cars_rf, prototype_data = mtcars[,-1])
#'
#' @rdname vetiver_create_ptype
#' @export
vetiver_ptype <- function(model, ...) {
    UseMethod("vetiver_ptype")
}

#' @rdname vetiver_create_ptype
#' @export
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_create_ptype <- function(model, save_prototype, ...) {
    check_dots_used()
    if (isTRUE(save_prototype)) {
        ptype <- vetiver_ptype(model, ...)
    } else if (isFALSE(save_prototype)) {
        ptype <- NULL
    } else if (rlang::inherits_any(save_prototype, "data.frame")) {
        return(save_prototype)
    } else {
        abort("The `save_prototype` argument must be TRUE, FALSE, or a dataframe.")
    }
    ptype
}

check_ptype_data <- function(dots, call = rlang::caller_env()) {
    if (!rlang::has_name(dots, "prototype_data")) {
        abort(c("No `prototype_data` available to create an input data prototype",
                "Pass at least one row of training features as `prototype_data`",
                "See the documentation for `vetiver_ptype()`"),
              call = call)
    }
}


preds_lm_ish <- function(model) {
    .terms <- terms(model)
    terms_matrix <- attr(.terms, "factors")
    terms_names <- colnames(terms_matrix)
    terms_exprs <- parse_exprs(terms_names)
    has_interactions <- map_lgl(terms_exprs, expr_contains, what = as.name(":"))
    terms_names[!has_interactions]
}

expr_contains <- function(expr, what) {
    switch(typeof(expr),
           symbol = identical(expr, what),
           call = call_contains(expr, what),
           language = call_contains(expr, what),
           FALSE
    )
}

call_contains <- function(expr, what, call = rlang::caller_env()) {
    if (length(expr) == 0L) {
        abort("Internal error, `expr` should be at least length 1.", call = call)
    }

    # Recurse into elements
    contains <- map_lgl(as.list(expr), expr_contains, what = what)
    any(contains)
}