-
Notifications
You must be signed in to change notification settings - Fork 28
/
pin-read-write.R
150 lines (134 loc) · 5.07 KB
/
pin-read-write.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
#' 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."
)
}