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
|
#' Constructor for a base model
#'
#' A __model__ is a _scalar object_, as classified in
#' [Advanced R](https://adv-r.hadley.nz/s3.html#object-styles). As such, it
#' takes uniquely named elements in `...` and combines them into a list with
#' a class of `class`. This entire object represent a single model.
#'
#' Because every model should have multiple interfaces, including formula
#' and `recipes` interfaces, all models should have a `blueprint` that
#' can process new data when `predict()` is called. The easiest way to generate
#' an blueprint with all of the information required at prediction time is to
#' use the one that is returned from a call to [mold()].
#'
#' @param ... Name-value pairs for elements specific to the model defined by
#' `class`.
#'
#' @param blueprint A preprocessing `blueprint` returned from a call to [mold()].
#'
#' @param class A character vector representing the class of the model.
#'
#' @return
#'
#' A new scalar model object, represented as a classed list with named elements
#' specified in `...`.
#'
#' @examples
#' new_model(
#' custom_element = "my-elem",
#' blueprint = default_xy_blueprint(),
#' class = "custom_model"
#' )
#' @export
new_model <- function(..., blueprint = default_xy_blueprint(), class = character()) {
validate_is_blueprint(blueprint)
new_abstract_model(..., blueprint = blueprint, class = c(class, "hardhat_model"))
}
# ------------------------------------------------------------------------------
#' @export
print.hardhat_model <- function(x, ...) {
cat_line("<", class(x)[1], ">")
x$blueprint <- NULL
print(unclass(x))
}
cat_line <- function(...) {
cat(paste0(..., "\n", collapse = ""))
}
# ------------------------------------------------------------------------------
new_abstract_model <- function(..., class) {
elems <- list2(...)
validate_has_unique_names(elems, "...")
new_scalar(elems, class = class)
}
new_scalar <- function(elems, ..., class = character()) {
check_elems(elems)
structure(elems, ..., class = c(class, "hardhat_scalar"))
}
# ------------------------------------------------------------------------------
check_elems <- function(elems) {
if (!is.list(elems) || length(elems) == 0) {
abort("`elems` must be a list of length 1 or greater.")
}
if (!has_unique_names(elems)) {
abort("`elems` must have unique names.")
}
if (!identical(names(attributes(elems)), "names")) {
abort("`elems` must have no attributes (apart from names).")
}
invisible(elems)
}
validate_is_blueprint <- function(blueprint) {
validate_is(blueprint, is_blueprint, "blueprint")
}
|
