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