1library(glue)
2
3# set up the boilerplate for a new step or check
4# creates a prefilled script in /R
5# and an empty script in /tests
6# consider using @inheritParams where appropriate instead of full boilerplate
7make_new <- function(name,
8                     which = c("step", "check")) {
9  which <- match.arg(which)
10  stopifnot(is.character(name))
11
12  in_recipes_root <-
13    tail(stringr::str_split(getwd(), "/")[[1]], 1) == "recipes"
14  if (!in_recipes_root) {
15    rlang::abort("Change working directory to package root")
16  }
17
18  if (glue::glue("{name}.R") %in% list.files("./R")) {
19    rlang::abort("step or check already present with this name in /R")
20  }
21
22  boilerplate <-
23    glue("
24{create_documentation(name, which)}
25{create_function(name, which)}
26{create_generator(name, which)}
27{create_prep_method(name, which)}
28{create_bake_method(name, which)}
29{create_print_method(name, which)}
30{create_tidy_method(name, which)}
31    ")
32
33  file.create(glue("./R/{name}.R"))
34  cat(boilerplate, file = glue("./R/{name}.R"))
35  file.create(glue("./tests/testthat/test_{name}.R"))
36}
37
38create_documentation <- function(name,
39                                 which) {
40  glue("
41#' <Title>
42#'
43#' `{which}_{name}` creates a *specification* of a recipe
44#'  {which} that <what it does>
45#'
46#' @param recipe A recipe object. The {which} will be added to the
47#'  sequence of operations for this recipe.
48#' @param ... One or more selector functions to choose which
49#'  variables are affected by the step. See [selections()]
50#'  for more details. For the `tidy` method, these are not
51#'  currently used.
52#' @param role Not used by this step since no new variables are
53#'  created. <change if role is used>
54#' @param trained A logical to indicate if the quantities for
55#'  preprocessing have been estimated.
56#' <additional args here>
57#' @param skip A logical. Should the step be skipped when the
58#'  recipe is baked by [bake.recipe()]? While all operations are baked
59#'  when [prep.recipe()] is run, some operations may not be able to be
60#'  conducted on new data (e.g. processing the outcome variable(s)).
61#'  Care should be taken when using `skip = TRUE` as it may affect
62#'  the computations for subsequent operations
63#' @param id A character string that is unique to this step to identify it.
64#' @return <describe return>
65#'
66#' @export
67#' @details <describe details>
68#'
69#' @examples
70
71  ")
72}
73
74create_function <- function(name, which) {
75  glue('
76{which}_{name} <-
77    function(recipe,
78             ...,
79             role = NA,
80             trained = FALSE,
81             <additional args here>
82             skip = FALSE,
83             id = rand_id("{name}")) {{
84      add_{which}(
85        recipe,
86        {which}_{name}_new(
87          terms = ellipse_check(...),
88          trained = trained,
89          role = role,
90          <additional args here>
91          skip = skip,
92          id = id
93        )
94      )
95    }}
96
97')
98}
99
100create_generator <- function(name, which) {
101  glue('
102  {which}_{name}_new <-
103    function(terms, role, <additional args here>, na_rm, skip, id) {{
104      step(
105        subclass = "{name}",
106        terms = terms,
107        role = role,
108        trained = trained,
109        <additional args here>
110        skip = skip,
111        id = id
112      )
113    }}
114
115  ')
116}
117
118create_prep_method <- function(name, which) {
119  glue('
120prep.{which}_{name} <- function(x, training, info = NULL, ...) {{
121  col_names <- recipes_eval_select(x$terms, training, info)
122  check_type(training[, col_names])
123
124  <prepping action here>
125
126  {which}_{name}_new(
127    terms = x$terms,
128    role = x$role,
129    trained = TRUE,
130    <additional args here>
131    skip = x$skip,
132    id = x$id
133  )
134}}
135
136')
137}
138
139create_bake_method <- function(name, which) {
140  glue('
141bake.{which}_{name} <- function(object, new_data, ...) {{
142  <baking actions here>
143  as_tibble(new_data)
144}}
145
146')
147}
148
149create_print_method <- function(name, which) {
150  glue('
151print.{which}_{name} <-
152  function(x, width = max(20, options()$width - 30), ...) {{
153    cat("<describe action here> ", sep = "")
154    printer(names(x$means), x$terms, x$trained, width = width)
155    invisible(x)
156  }}
157
158')
159}
160
161create_tidy_method <- function(name, which) {
162  glue("
163#' @rdname {which}_{name}
164#' @param x A `{which}_{name}` object.
165#' @export
166tidy.{which}_{name} <- function(x, ...) {{
167  if (is_trained(x)) {{
168    res <-
169    <action here>
170  }} else {{
171    term_names <- sel2char(x$terms)
172    res <- tibble(terms = term_names,
173                  value = na_dbl)
174  }}
175  res$id <- x$id
176  res
177}}
178  ")
179}
180