library(glue)
# set up the boilerplate for a new step or check
# creates a prefilled script in /R
# and an empty script in /tests
# consider using @inheritParams where appropriate instead of full boilerplate
make_new <- function(name,
which = c("step", "check")) {
which <- match.arg(which)
stopifnot(is.character(name))
in_recipes_root <-
tail(stringr::str_split(getwd(), "/")[[1]], 1) == "recipes"
if (!in_recipes_root) {
rlang::abort("Change working directory to package root")
}
if (glue("{name}.R") %in% list.files("./R")) {
rlang::abort("step or check already present with this name in /R")
}
boilerplate <-
glue("
{create_documentation(name, which)}
{create_function(name, which)}
{create_generator(name, which)}
{create_prep_method(name, which)}
{create_bake_method(name, which)}
{create_print_method(name, which)}
{create_tidy_method(name, which)}
")
file.create(glue("./R/{name}.R"))
cat(boilerplate, file = glue("./R/{name}.R"))
file.create(glue("./tests/testthat/test_{name}.R"))
}
create_documentation <- function(name,
which) {
glue("
#'
#'
#' `{which}_{name}` creates a *specification* of a recipe
#' {which} that
#'
#' @param recipe A recipe object. The {which} will be added to the
#' sequence of operations for this recipe.
#' @param ... One or more selector functions to choose which
#' variables are affected by the step. See [selections()]
#' for more details. For the `tidy` method, these are not
#' currently used.
#' @param role Not used by this step since no new variables are
#' created.
#' @param trained A logical to indicate if the quantities for
#' preprocessing have been estimated.
#'
#' @param skip A logical. Should the step be skipped when the
#' recipe is baked by [bake()]? While all operations are baked
#' when [prep()] is run, some operations may not be able to be
#' conducted on new data (e.g. processing the outcome variable(s)).
#' Care should be taken when using `skip = TRUE` as it may affect
#' the computations for subsequent operations
#' @param id A character string that is unique to this step to identify it.
#' @return
#'
#' @export
#' @details
#'
#' # Tidying
#'
#' When you [`tidy()`][tidy.recipe()] this step, a tibble with columns
#' is returned.
#'
#' @examples
")
}
create_function <- function(name, which) {
glue('
{which}_{name} <-
function(recipe,
...,
role = NA,
trained = FALSE,
skip = FALSE,
id = rand_id("{name}")) {{
add_{which}(
recipe,
{which}_{name}_new(
terms = enquos(...),
trained = trained,
role = role,
skip = skip,
id = id
)
)
}}
')
}
create_generator <- function(name, which) {
glue('
{which}_{name}_new <-
function(terms, role, , na_rm, skip, id) {{
step(
subclass = "{name}",
terms = terms,
role = role,
trained = trained,
skip = skip,
id = id
)
}}
')
}
create_prep_method <- function(name, which) {
glue("
#' @export
prep.{which}_{name} <- function(x, training, info = NULL, ...) {{
col_names <- recipes_eval_select(x$terms, training, info)
check_type(training[, col_names])
{which}_{name}_new(
terms = x$terms,
role = x$role,
trained = TRUE,
skip = x$skip,
id = x$id
)
}}
")
}
create_bake_method <- function(name, which) {
glue("
#' @export
bake.{which}_{name} <- function(object, new_data, ...) {{
as_tibble(new_data)
}}
")
}
create_print_method <- function(name, which) {
glue('
print.{which}_{name} <-
function(x, width = max(20, options()$width - 30), ...) {{
title <- " "
print_step(names(x$means), x$terms, x$trained, title, width)
invisible(x)
}}
')
}
create_tidy_method <- function(name, which) {
glue("
#' @rdname tidy.recipe
#' @export
tidy.{which}_{name} <- function(x, ...) {{
if (is_trained(x)) {{
res <-
}} else {{
term_names <- sel2char(x$terms)
res <- tibble(terms = term_names,
value = na_dbl)
}}
res$id <- x$id
res
}}
")
}