R/open-api-spec.R

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

#' Identify data types for each column in an input data prototype
#'
#' The OpenAPI specification of a Plumber API created via [plumber::pr()] can
#' be modified via [plumber::pr_set_api_spec()], and this helper function will
#' identify data types of predictors and create a list to use in this
#' specification. These are *not* R data types, but instead basic JSON data
#' types. For example, factors in R will be documented as strings in the
#' OpenAPI specification.
#'
#' @param prototype An input data prototype from a model
#'
#' @return A list to be used within [plumber::pr_set_api_spec()]
#'
#' @details
#' This is a developer-facing function, useful for supporting new model types.
#' It is called by [api_spec()].
#'
#' @examples
#' map_request_body(vctrs::vec_slice(chickwts, 0))
#'
#' @export
map_request_body <- function(prototype) {
    UseMethod("map_request_body")
}

#' @export
map_request_body.default <- function(prototype) {
    abort("There is no method available to create visual documentation for `prototype`.")
}

#' @export
map_request_body.data.frame <- function(prototype) {
    ptype_prop <- map_ptype(prototype)

    if (nrow(prototype) > 0) {
        schema_list <- list(
            type = "array",
            minItems = 1,
            items = list(
                type = "object",
                properties = ptype_prop
            ),
            example = purrr::pmap(prototype, list)
        )
    } else {
        schema_list <- list(
            type = "array",
            minItems = 1,
            items = list(
                type = "object",
                properties = ptype_prop
            )
        )
    }

    list(content = list(`application/json` = list(schema = schema_list)))
}

map_ptype <- function(ptype) {
    ret <- as.list(ptype)
    ## use `plumber:::plumberToApiTypeMap` here instead?
    ret <- map(
        ret,
        ~ switch(class(.)[[1]],
                 numeric = "number",
                 integer = "integer",
                 logical = "boolean",
                 "string"
        )
    )
    map(ret, ~ list(type = .))
}


#' @export
map_request_body.array <- function(prototype) {

    dims <- dim(prototype)
    ptype_prop <- map(dims, ~ list(type = "array",
                                   minItems = .x,
                                   maxItems = .x,
                                   type = "number"))
    ptype_prop <- set_names(ptype_prop, glue("dim{seq_along(dims)}"))

    if (dims[1] > 0) {
        schema_list <- list(
            type = "array",
            minItems = 1,
            items = list(
                type = "object",
                properties = ptype_prop
            ),
            example = prototype
        )
    } else {
        schema_list <- list(
            type = "array",
            minItems = 1,
            items = list(
                type = "object",
                properties = ptype_prop
            )
        )
    }

    list(content = list(`application/json` = list(schema = schema_list)))
}


#' Update the OpenAPI specification using model metadata
#'
#' @param spec An OpenAPI Specification formatted list object
#' @inheritParams vetiver_api
#' @inheritParams map_request_body
#' @param return_type Character string to describe what endpoint returns, such
#' as "predictions"
#'
#' @return `api_spec()` returns the updated OpenAPI Specification object. This
#' function uses `glue_spec_summary()` internally, which returns a `glue`
#' character string.
#' @export
#'
#' @examplesIf rlang::is_installed("plumber")
#' library(plumber)
#' cars_lm <- lm(mpg ~ ., data = mtcars)
#' v <- vetiver_model(cars_lm, "cars_linear")
#'
#' glue_spec_summary(v$prototype)
#'
#' modify_spec <- function(spec) api_spec(spec, v, "/predict")
#' pr() %>% pr_set_api_spec(api = modify_spec)
#'
api_spec <- function(spec, vetiver_model, path, all_docs = TRUE) {
    spec$info$title <- glue("{vetiver_model$model_name} model API")
    spec$info$description <- vetiver_model$description
    spec$info$version <- vetiver_model$metadata$version
    if ("/pin-url" %in% names(spec$paths)) {
        spec$paths$`/pin-url`$get$summary <- "Get URL of pinned vetiver model"
    }
    if ("/metadata" %in% names(spec$paths)) {
        spec$paths$`/metadata`$get$summary <- "Get all metadata of pinned vetiver model"
    }
    if ("/prototype" %in% names(spec$paths)) {
        spec$paths$`/prototype`$get$summary <- "Get input data prototype for vetiver model"
    }
    if ("/ping" %in% names(spec$paths)) {
        spec$paths$`/ping`$get$summary <- "Health check"
    }


    ptype <- vetiver_model$prototype
    if (is_null(ptype)) {
        request_body <- map_request_body(tibble::tibble(NULL))
        summary <- "Return predictions from model"
    } else {
        request_body <- map_request_body(ptype)
        summary <- glue_spec_summary(ptype)
    }

    if (all_docs) {
        endpoints <- map_chr(spec$paths, names)
        endpoints <- names(endpoints[endpoints == "post"])
        endpoints <- setdiff(endpoints, path)

        spec <- update_spec(spec, path, summary, request_body)

        for (endpoint in endpoints) {
            endpoint_summary <- glue_spec_summary(ptype, endpoint)
            spec <- update_spec(spec, endpoint, endpoint_summary, request_body)
        }
    }

    if (has_connect_redirect(spec)) {
        spec$paths$`/` <- NULL
    }

    spec
}

update_spec <- function(spec, endpoint, summary, request_body) {
    orig_post <- pluck(spec, "paths", endpoint, "post")
    spec$paths[[endpoint]]$post <- list(
        summary = summary,
        requestBody = request_body,
        responses = orig_post$responses
    )
    spec
}

has_connect_redirect <- function(spec) {
    endpoint <- spec$paths$`/`
    summary <- endpoint$get$summary
    connect_summary <-
        grepl("^This endpoint was added to automatically redirect visitors", summary)

    if (is.null(endpoint) || is.null(summary) || !connect_summary) {
        return(FALSE)
    } else {
        return(TRUE)
    }
}

#' @rdname api_spec
#' @export
glue_spec_summary <- function(prototype, return_type) {
    UseMethod("glue_spec_summary")
}

#' @rdname api_spec
#' @export
glue_spec_summary.default <- function(prototype, return_type = NULL) {
    abort("There is no method available to create a spec summary for `ptype`.")
}

#' @rdname api_spec
#' @export
glue_spec_summary.data.frame <- function(prototype, return_type = "predictions") {
    cli::pluralize("Return {return_type} from model using {ncol(prototype)} feature{?s}")
}

#' @rdname api_spec
#' @export
glue_spec_summary.array <- function(prototype, return_type = "predictions") {
    "Return {return_type} from model using multidimensional array"
}