diff --git a/DESCRIPTION b/DESCRIPTION
index 839c91d..ca0c54e 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -61,4 +61,4 @@ Config/testthat/edition: 3
Config/usethis/last-upkeep: 2025-04-24
Encoding: UTF-8
Roxygen: list(markdown = TRUE)
-Config/roxygen2/version: 8.0.0
+Config/roxygen2/version: 8.1.0
diff --git a/NAMESPACE b/NAMESPACE
index 7ee9f61..ade8a6f 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,5 +1,6 @@
# Generated by roxygen2: do not edit by hand
+S3method(bake,step_adjust_linear)
S3method(bake,step_collapse_cart)
S3method(bake,step_collapse_stringdist)
S3method(bake,step_discretize_cart)
@@ -14,6 +15,7 @@ S3method(bake,step_pca_sparse_bayes)
S3method(bake,step_pca_truncated)
S3method(bake,step_umap)
S3method(bake,step_woe)
+S3method(prep,step_adjust_linear)
S3method(prep,step_collapse_cart)
S3method(prep,step_collapse_stringdist)
S3method(prep,step_discretize_cart)
@@ -28,6 +30,7 @@ S3method(prep,step_pca_sparse_bayes)
S3method(prep,step_pca_truncated)
S3method(prep,step_umap)
S3method(prep,step_woe)
+S3method(print,step_adjust_linear)
S3method(print,step_collapse_cart)
S3method(print,step_collapse_stringdist)
S3method(print,step_discretize_cart)
@@ -42,6 +45,7 @@ S3method(print,step_pca_sparse_bayes)
S3method(print,step_pca_truncated)
S3method(print,step_umap)
S3method(print,step_woe)
+S3method(required_pkgs,step_adjust_linear)
S3method(required_pkgs,step_collapse_cart)
S3method(required_pkgs,step_collapse_stringdist)
S3method(required_pkgs,step_discretize_cart)
@@ -56,6 +60,7 @@ S3method(required_pkgs,step_pca_sparse_bayes)
S3method(required_pkgs,step_pca_truncated)
S3method(required_pkgs,step_umap)
S3method(required_pkgs,step_woe)
+S3method(tidy,step_adjust_linear)
S3method(tidy,step_collapse_cart)
S3method(tidy,step_collapse_stringdist)
S3method(tidy,step_discretize_cart)
@@ -82,6 +87,7 @@ export(add_woe)
export(dictionary)
export(embed_control)
export(required_pkgs)
+export(step_adjust_linear)
export(step_collapse_cart)
export(step_collapse_stringdist)
export(step_discretize_cart)
@@ -101,39 +107,51 @@ export(tidy)
export(tunable)
import(recipes)
import(rlang)
-importFrom(dplyr,arrange)
-importFrom(dplyr,bind_rows)
-importFrom(dplyr,contains)
-importFrom(dplyr,ends_with)
-importFrom(dplyr,filter)
-importFrom(dplyr,left_join)
-importFrom(dplyr,mutate)
-importFrom(dplyr,one_of)
-importFrom(generics,required_pkgs)
-importFrom(generics,tidy)
-importFrom(generics,tunable)
+importFrom(dplyr,
+ arrange,
+ bind_rows,
+ contains,
+ ends_with,
+ filter,
+ left_join,
+ mutate,
+ one_of
+)
+importFrom(generics,
+ required_pkgs,
+ tidy,
+ tunable
+)
importFrom(glue,glue)
importFrom(lifecycle,deprecated)
importFrom(recipes,remove_original_cols)
-importFrom(stats,as.formula)
-importFrom(stats,binomial)
-importFrom(stats,coef)
-importFrom(stats,complete.cases)
-importFrom(stats,gaussian)
-importFrom(stats,glm)
-importFrom(stats,model.matrix)
-importFrom(stats,na.omit)
-importFrom(stats,setNames)
-importFrom(tibble,as_tibble)
-importFrom(tibble,rownames_to_column)
-importFrom(tibble,tibble)
+importFrom(stats,
+ as.formula,
+ binomial,
+ coef,
+ complete.cases,
+ gaussian,
+ glm,
+ model.matrix,
+ na.omit,
+ setNames
+)
+importFrom(tibble,
+ as_tibble,
+ rownames_to_column,
+ tibble
+)
importFrom(tidyr,gather)
-importFrom(utils,capture.output)
-importFrom(utils,compareVersion)
-importFrom(utils,globalVariables)
-importFrom(utils,packageVersion)
-importFrom(utils,stack)
-importFrom(uwot,umap)
-importFrom(uwot,umap_transform)
+importFrom(utils,
+ capture.output,
+ compareVersion,
+ globalVariables,
+ packageVersion,
+ stack
+)
+importFrom(uwot,
+ umap,
+ umap_transform
+)
importFrom(vctrs,vec_cbind)
importFrom(withr,with_seed)
diff --git a/NEWS.md b/NEWS.md
index cd5a018..89b26f4 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,9 @@
# embed (development version)
+## New Steps
+
+* Added `step_adjust_linear()` for linear residualization of selected outcomes against nuisance variables.
+
# embed 1.2.2
* Fixed bug on step_umap() where the number of calculated components would be zero. (#271)
@@ -87,7 +91,7 @@
# embed 1.0.0
-* `step_collapse_cart()` can pool a predictor's factor levels using a tree-based method.
+* `step_collapse_cart()` can pool a predictor's factor levels using a tree-based method.
* `step_collapse_stringdist()` can pool a predictor's factor levels using string distances.
@@ -109,7 +113,7 @@
* Re-licensed package from GPL-2 to MIT. See [consent from copyright holders here](https://github.com/tidymodels/embed/issues/78).
-* The tunable parameter ranges for `step_umap()` were changed for `neighbors`, `num_comp`, and `min_dist` to prevent `uwot` segmentation faults. The step also check to see if the data dimensions are consistent with the argument values.
+* The tunable parameter ranges for `step_umap()` were changed for `neighbors`, `num_comp`, and `min_dist` to prevent `uwot` segmentation faults. The step also check to see if the data dimensions are consistent with the argument values.
* Two new PCA steps were added, each using sparse techniques for estimation: `step_pca_sparse()` and `step_pca_sparse_bayes()`.
@@ -124,78 +128,78 @@
# embed 0.1.4
- * Minor release with changes to test for cases when CRAN cannot get `xgboost` to work on their Solaris configuration.
-
- * `lme4` and `rstanarm` are now in the Suggests list so they are not automatically installed with `embed`. A message is written to the console if those packages are missing and their associated steps functions are invoked.
+ * Minor release with changes to test for cases when CRAN cannot get `xgboost` to work on their Solaris configuration.
+
+ * `lme4` and `rstanarm` are now in the Suggests list so they are not automatically installed with `embed`. A message is written to the console if those packages are missing and their associated steps functions are invoked.
# embed 0.1.3
- * More changes to enable better parallel processing on windows.
+ * More changes to enable better parallel processing on windows.
# embed 0.1.2
- * Changes to enable better parallel processing on windows.
+ * Changes to enable better parallel processing on windows.
# embed 0.1.1
* Changes to tests to get out of archive jail.
-
- * Updated the plumbing behind `step_woe()`.
-
- * Due to a bug in `tensorflow`, added a "warm start" to instigate a TF session if one does not currently exist.
-
+
+ * Updated the plumbing behind `step_woe()`.
+
+ * Due to a bug in `tensorflow`, added a "warm start" to instigate a TF session if one does not currently exist.
+
# embed 0.1.0
* Changes for `dplyr` 1.0.0
-
+
## New Steps
-
- * `step_discretize_xgb()` and `step_discretize_cart()` can be used to convert numeric predictors to categorical using supervised binning methods based on tree models. Thanks to Konrad Semsch for the contribution.
- * Added `step_feature_hash()` for creating dummy variables using feature hashing.
+ * `step_discretize_xgb()` and `step_discretize_cart()` can be used to convert numeric predictors to categorical using supervised binning methods based on tree models. Thanks to Konrad Semsch for the contribution.
+
+ * Added `step_feature_hash()` for creating dummy variables using feature hashing.
## Breaking Changes
- * `tidy.step_woe()` now has column names consistent with other recipe steps.
+ * `tidy.step_woe()` now has column names consistent with other recipe steps.
## Bug fixes
- * Fixed a bug in detecting the TF version.
+ * Fixed a bug in detecting the TF version.
# embed 0.0.6
-* Small changes for base R's `stringsAsFactors` change.
+* Small changes for base R's `stringsAsFactors` change.
# `embed` 0.0.5
- * The example data are now in the `modeldata` package.
-
- * Small TF updates to `step_embed()`.
+ * The example data are now in the `modeldata` package.
+
+ * Small TF updates to `step_embed()`.
# `embed` 0.0.4
* Methods were added for a future generic called `tunable()`. This outlines which parameters in a step can/could be tuned.
- * Small updates to work with different versions of `tidyr`.
-
+ * Small updates to work with different versions of `tidyr`.
+
# `embed` 0.0.3
## New Steps
- * `step_umap()` was added for both supervised and unsupervised encodings.
+ * `step_umap()` was added for both supervised and unsupervised encodings.
* `step_woe()` created weight of evidence encodings.
# `embed` 0.0.2
-A mostly maintainence release to be compatible with version 0.1.3 of `recipes`.
+A mostly maintainence release to be compatible with version 0.1.3 of `recipes`.
## Other Changes:
- * The package now depends on the `generics` pacakge to get the `broom` `tidy` methods.
+ * The package now depends on the `generics` pacakge to get the `broom` `tidy` methods.
* Karim Lahrichi added the ability to use callbacks when fitting tensorflow models. [PR](https://github.com/tidymodels/embed/pull/9)
diff --git a/R/adjust_linear.R b/R/adjust_linear.R
new file mode 100644
index 0000000..11798a5
--- /dev/null
+++ b/R/adjust_linear.R
@@ -0,0 +1,376 @@
+#' Adjust variables using a linear model
+#'
+#' `step_adjust_linear()` creates a *specification* of a recipe step that will
+#' adjust a variable or group of variables by linearly "residualizing out" other
+#' variable(s).
+#'
+#' @inheritParams recipes::step_pca
+#' @param role Not used by this step since no new variables are created.
+#' @param remove_vars One or more selector functions to choose variables to
+#' residualize out. The predicted term-values for these variables are
+#' subtracted from the outcome (`...`).
+#' @param keep_vars One or more selector functions to choose variables to
+#' _not_ residualize out.
+#' @param models The [stats::lm()] object is stored here once this preprocessing
+#' step has be trained by [recipes::prep()].
+#' @param drop When [recipes::bake()] is called, should the `remove_vars`
+#' variables be removed (`"remove"`; default), also the `keep_vars` variables
+#' (`"both"`) or should no variables be removed (all kept; `"none"`).
+#' @template step-return
+#' @details
+#'
+#' For each selected variable, `step_adjust_linear()` fit a _linear_ model:
+#'
+#' ```R
+#' lm(variable ~ remove_vars + keep_vars)
+#' ```
+#'
+#' And then adjusts `variable` but subtracting from the it sum of the predicted
+#' term-wise values of `remove_vars` (using
+#' [`stats::predict.lm(term = remove_vars)`][stats::predict.lm]. This is similar
+#' to the functionality provided by [limma::removeBatchEffect()], and is
+#' particularly useful for "removing" unwanted batch effects from
+#' log-gen-expression outcomes associated with technical variables (possibly
+#' without removing experimental design or grouping variables), but can be
+#' applied to any situation where variables need to be adjusted as part of
+#' pre-processing.
+#'
+#' (Prior to model fitting, numerical `remove_vars` / `keep_vars` are centered
+#' and factors are effect-encoded using [stats::contr.sum()].)
+#'
+#' Note that the original data will be replaced with the adjusted data, possibly
+#' dropping the `remove_vars` / `keep_vars` (depending on the value of the `drop` argument).
+#'
+#' # Tidying
+#'
+#' When you [`tidy()`][recipes::tidy.recipe] this step, a tibble is returned with
+#' columns `variables`, `term`, `type`, `value`, and `id`:
+#'
+#' \describe{
+#' \item{variables}{character, the selectors or variables selected}
+#' \item{term}{character, the variables to remove or keep / coefficient label}
+#' \item{type}{character, either "remove" or "keep"}
+#' \item{value}{numeric, the coefficient value for the term}
+#' \item{id}{character, id of this step}
+#' }
+#'
+#' @template case-weights-supervised
+#'
+#' @examplesIf rlang::is_installed(c("modeldata", "ggplot2"))
+#'
+#' library(ggplot2)
+#'
+#' data("penguins", package = "modeldata")
+#' penguins <- na.omit(penguins)
+#'
+#' p <- ggplot(penguins, aes(flipper_length_mm, body_mass_g, color = sex)) +
+#' geom_point(aes(shape = species)) +
+#' stat_ellipse() +
+#' labs(title = "No adjustment")
+#'
+#' p
+#'
+#'
+#' recipe <- recipe(body_mass_g ~ ., data = penguins) |>
+#' step_adjust_linear(
+#' flipper_length_mm,
+#' body_mass_g,
+#' remove_vars = vars(species),
+#' keep_vars = vars(sex),
+#' drop = "none" # keep all variables in the baked data
+#' )
+#'
+#' baked <- prep(recipe) |>
+#' bake(new_data = penguins)
+#'
+#' ggplot2::ggplot_add(baked, p) +
+#' labs(title = "Adjustment for species")
+#'
+#'
+#' @export
+step_adjust_linear <- function(
+ recipe,
+ ...,
+ role = NA,
+ trained = FALSE,
+ remove_vars = NULL,
+ keep_vars = NULL,
+ models = NULL,
+ drop = c("remove", "both", "none"),
+ skip = FALSE,
+ id = rand_id("adjust_linear")
+) {
+ add_step(
+ recipe,
+ step_adjust_linear_new(
+ terms = enquos(...),
+ role = role,
+ trained = trained,
+ remove_vars = remove_vars,
+ keep_vars = keep_vars,
+ models = models,
+ drop = drop,
+ skip = skip,
+ id = id,
+ case_weights = NULL
+ )
+ )
+}
+
+step_adjust_linear_new <- function(
+ terms,
+ role,
+ trained,
+ remove_vars,
+ keep_vars,
+ models,
+ drop,
+ skip,
+ id,
+ case_weights
+) {
+ step(
+ subclass = "adjust_linear",
+ terms = terms,
+ role = role,
+ trained = trained,
+ remove_vars = remove_vars,
+ keep_vars = keep_vars,
+ models = models,
+ drop = drop,
+ skip = skip,
+ id = id,
+ case_weights = case_weights
+ )
+}
+
+#' @export
+prep.step_adjust_linear <- function(x, training, info = NULL, ...) {
+ wts <- get_case_weights(info, training)
+ were_weights_used <- are_weights_used(wts)
+ if (isFALSE(were_weights_used)) {
+ wts <- rep(1, nrow(training))
+ }
+
+ col_names <- recipes_eval_select(x$terms, training, info)
+
+ if (is.null(x$remove_vars)) {
+ cli::cli_abort(
+ c(
+ "The `remove_vars` argument must be specified.",
+ "i" = "This is the variable(s) you want to remove the effect of."
+ )
+ )
+ }
+
+ remove_names <- recipes_eval_select(x$remove_vars, training, info)
+
+ # Identify Preserved columns (Design)
+ # Handle case where keep_vars is NULL
+ if (!is.null(x$keep_vars)) {
+ keep_names <- recipes_eval_select(x$keep_vars, training, info)
+
+ if (any(keep_names %in% remove_names)) {
+ cli::cli_abort(
+ c(
+ "The `keep_vars` and `remove_vars` selectors must be disjoint.",
+ "x" = "The following variables are in both: {intersect(keep_names, remove_names)}"
+ )
+ )
+ }
+ } else {
+ keep_names <- NULL
+ }
+
+ .contrasts <- NULL
+ all_names <- c(remove_names, keep_names)
+ is_fct <- purrr::map_lgl(all_names, \(v) is.factor(training[[v]]))
+ is_num <- purrr::map_lgl(all_names, \(v) is.numeric(training[[v]]))
+ other_names <- all_names[!(is_fct | is_num)]
+
+ if (length(other_names) > 0L) {
+ cli::cli_abort(
+ c(
+ "The `remove_vars` and `keep_vars` selectors must be either factors or numeric.",
+ "x" = "The following variable is neither: {other_names}"
+ )
+ )
+ }
+
+ if (any(is_num)) {
+ all_names[is_num] <- sprintf("scale(%s, scale = FALSE)", all_names[is_num])
+ }
+
+ if (any(is_fct)) {
+ .contrasts <- stats::setNames(
+ rep(list("contr.sum"), sum(is_fct)),
+ all_names[is_fct]
+ )
+ }
+
+ model_list <- list()
+
+ for (col in col_names) {
+ # Create formula: Target ~ Remove1 + Keep1 + ...
+ # We combine both sets of variables for the fit
+ ff <- stats::reformulate(
+ response = col,
+ termlabels = all_names
+ )
+
+ # Fit and store the model
+ model_list[[col]] <- stats::lm(
+ ff,
+ data = training,
+ weights = wts,
+ contrasts = .contrasts
+ )
+ }
+
+ drop <- match.arg(x$drop, choices = c("remove", "both", "none"))
+
+ step_adjust_linear_new(
+ terms = col_names,
+ role = x$role,
+ trained = TRUE,
+ remove_vars = remove_names,
+ keep_vars = keep_names,
+ models = model_list,
+ drop = drop,
+ skip = x$skip,
+ id = x$id,
+ case_weights = were_weights_used
+ )
+}
+
+#' @export
+bake.step_adjust_linear <- function(object, new_data, ...) {
+ remove_names <- object$remove_vars
+ keep_names <- object$keep_vars
+
+ check_new_data(
+ unique(c(names(object$models), remove_names, keep_names)),
+ object,
+ new_data
+ )
+
+ for (col in names(object$models)) {
+ model <- object$models[[col]]
+
+ # Crucial Step: use type = "terms"
+ # This returns a matrix with one column per independent variable,
+ # representing that variable's contribution to the prediction.
+ # It handles factors (dummification) automatically.
+ term_preds <- stats::predict(model, newdata = new_data, type = "terms")
+
+ # Identify which columns in the term matrix correspond to our `remove_vars`
+ # Note: `predict` names columns by the variable name.
+ cols_to_subtract <-
+ gsub("^scale\\((.*), scale = FALSE\\)$", "\\1", colnames(term_preds)) %in%
+ remove_names
+
+ if (any(cols_to_subtract)) {
+ # Sum the effects of the nuisance variables
+ nuisance_effect <- rowSums(term_preds[, cols_to_subtract, drop = FALSE])
+
+ # Subtract nuisance effect from original data
+ # Result = (Signal + Batch + Noise) - (Batch) = Signal + Noise
+ new_data[[col]] <- new_data[[col]] - nuisance_effect
+ }
+ }
+
+ if (object$drop == "remove") {
+ new_data <- new_data[,
+ !(colnames(new_data) %in% remove_names),
+ drop = FALSE
+ ]
+ } else if (object$drop == "both") {
+ new_data <- new_data[,
+ !(colnames(new_data) %in% c(remove_names, keep_names)),
+ drop = FALSE
+ ]
+ }
+
+ tibble::as_tibble(new_data)
+}
+
+#' @export
+print.step_adjust_linear <- function(
+ x,
+ width = max(20, options()$width - 30),
+ ...
+) {
+ title <- "Linearly adjusting variables"
+ print_step(
+ names(x$models),
+ x$terms,
+ x$trained,
+ title,
+ width,
+ case_weights = x$case_weights
+ )
+ invisible(x)
+}
+
+#' @rdname step_adjust_linear
+#' @usage NULL
+#' @export
+tidy.step_adjust_linear <- function(x, ...) {
+ to_chr <- function(y) {
+ if (is.null(y)) {
+ character(0)
+ } else if (is.character(y)) {
+ y
+ } else {
+ sel2char(y)
+ }
+ }
+
+ remove_vars <- to_chr(x$remove_vars)
+ keep_vars <- to_chr(x$keep_vars)
+
+ if (is_trained(x)) {
+ if (length(x$models) == 0) {
+ res <- tibble(
+ variables = character(),
+ term = character(),
+ type = character(),
+ value = double()
+ )
+ } else {
+ res <- purrr::map(x$models, \(mod) {
+ a <- attr(stats::model.matrix(mod), "assign")
+ a[a == 0] <- NA
+ trm <- attr(stats::terms(mod), "term.labels")
+ trm <- gsub("^scale\\((.*), scale = FALSE\\)$", "\\1", trm)
+ b <- stats::coef(mod)
+ tibble(term = names(b), type = trm[a], value = b)
+ }) |>
+ dplyr::bind_rows(.id = "variables")
+ }
+ } else {
+ term_names <- to_chr(x$terms)
+ res <- as_tibble(
+ expand.grid(
+ variables = term_names,
+ term = c(remove_vars, keep_vars),
+ stringsAsFactors = FALSE,
+ KEEP.OUT.ATTRS = FALSE
+ )
+ )
+ res$type <- res$term
+ res$value <- NA_real_
+ }
+
+ res$type[res$type %in% remove_vars] <- "remove"
+ res$type[res$type %in% keep_vars] <- "keep"
+ res <- res[order(res$variables), ]
+ res$id <- x$id
+ res
+}
+
+#' @rdname required_pkgs.embed
+#' @export
+required_pkgs.step_adjust_linear <- function(x, ...) {
+ c("embed")
+}
diff --git a/README.md b/README.md
index cf43b45..4f18a22 100644
--- a/README.md
+++ b/README.md
@@ -48,6 +48,9 @@ Some steps handle categorical predictors:
For numeric predictors:
+- `step_adjust_linear()` residualizes one or more numeric outcomes by
+ removing linear effects from selected nuisance variables.
+
- `step_umap()` uses a nonlinear transformation similar to t-SNE but can
be used to project the transformation on new data. Both supervised and
unsupervised methods can be used.
diff --git a/_pkgdown.yml b/_pkgdown.yml
index b8fb545..27f0e77 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -27,6 +27,7 @@ reference:
- step_collapse_stringdist
- title: Embed numeric predictors
contents:
+ - step_adjust_linear
- step_discretize_cart
- step_discretize_xgb
- step_pca_sparse
diff --git a/man/required_pkgs.embed.Rd b/man/required_pkgs.embed.Rd
index b2267c1..dabd7e5 100644
--- a/man/required_pkgs.embed.Rd
+++ b/man/required_pkgs.embed.Rd
@@ -1,9 +1,11 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/collapse_cart.R, R/collapse_stringdist.R,
-% R/discretize_cart.R, R/discretize_xgb.R, R/embed.R, R/lencode.R,
-% R/lencode_bayes.R, R/lencode_glm.R, R/lencode_mixed.R, R/pca_sparse.R,
-% R/pca_sparse_bayes.R, R/pca_truncated.R, R/umap.R, R/woe.R
-\name{required_pkgs.step_collapse_cart}
+% Please edit documentation in R/adjust_linear.R, R/collapse_cart.R,
+% R/collapse_stringdist.R, R/discretize_cart.R, R/discretize_xgb.R,
+% R/embed.R, R/lencode.R, R/lencode_bayes.R, R/lencode_glm.R,
+% R/lencode_mixed.R, R/pca_sparse.R, R/pca_sparse_bayes.R, R/pca_truncated.R,
+% R/umap.R, R/woe.R
+\name{required_pkgs.step_adjust_linear}
+\alias{required_pkgs.step_adjust_linear}
\alias{required_pkgs.step_collapse_cart}
\alias{required_pkgs.step_collapse_stringdist}
\alias{required_pkgs.step_discretize_cart}
@@ -20,6 +22,8 @@
\alias{required_pkgs.step_woe}
\title{S3 methods for tracking which additional packages are needed for steps.}
\usage{
+\method{required_pkgs}{step_adjust_linear}(x, ...)
+
\method{required_pkgs}{step_collapse_cart}(x, ...)
\method{required_pkgs}{step_collapse_stringdist}(x, ...)
diff --git a/man/step_adjust_linear.Rd b/man/step_adjust_linear.Rd
new file mode 100644
index 0000000..7c70a78
--- /dev/null
+++ b/man/step_adjust_linear.Rd
@@ -0,0 +1,139 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/adjust_linear.R
+\name{step_adjust_linear}
+\alias{step_adjust_linear}
+\alias{tidy.step_adjust_linear}
+\title{Adjust variables using a linear model}
+\usage{
+step_adjust_linear(
+ recipe,
+ ...,
+ role = NA,
+ trained = FALSE,
+ remove_vars = NULL,
+ keep_vars = NULL,
+ models = NULL,
+ drop = c("remove", "both", "none"),
+ skip = FALSE,
+ id = rand_id("adjust_linear")
+)
+}
+\arguments{
+\item{recipe}{A recipe object. The step will be added to the sequence of
+operations for this recipe.}
+
+\item{...}{One or more selector functions to choose variables for this step.
+See \code{\link[recipes:selections]{selections()}} for more details.}
+
+\item{role}{Not used by this step since no new variables are created.}
+
+\item{trained}{A logical to indicate if the quantities for preprocessing have
+been estimated.}
+
+\item{remove_vars}{One or more selector functions to choose variables to
+residualize out. The predicted term-values for these variables are
+subtracted from the outcome (\code{...}).}
+
+\item{keep_vars}{One or more selector functions to choose variables to
+\emph{not} residualize out.}
+
+\item{models}{The \code{\link[stats:lm]{stats::lm()}} object is stored here once this preprocessing
+step has be trained by \code{\link[recipes:prep]{recipes::prep()}}.}
+
+\item{drop}{When \code{\link[recipes:bake]{recipes::bake()}} is called, should the \code{remove_vars}
+variables be removed (\code{"remove"}; default), also the \code{keep_vars} variables
+(\code{"both"}) or should no variables be removed (all kept; \code{"none"}).}
+
+\item{skip}{A logical. Should the step be skipped when the recipe is baked by
+\code{\link[recipes:bake]{bake()}}? While all operations are baked when \code{\link[recipes:prep]{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 \code{skip = TRUE} as it
+may affect the computations for subsequent operations.}
+
+\item{id}{A character string that is unique to this step to identify it.}
+}
+\value{
+An updated version of \code{recipe} with the new step added to the
+sequence of any existing operations.
+}
+\description{
+\code{step_adjust_linear()} creates a \emph{specification} of a recipe step that will
+adjust a variable or group of variables by linearly "residualizing out" other
+variable(s).
+}
+\details{
+For each selected variable, \code{step_adjust_linear()} fit a \emph{linear} model:
+
+\if{html}{\out{}}\preformatted{lm(variable ~ remove_vars + keep_vars)
+}\if{html}{\out{
}}
+
+And then adjusts \code{variable} but subtracting from the it sum of the predicted
+term-wise values of \code{remove_vars} (using
+\code{\link[stats:predict.lm]{stats::predict.lm(term = remove_vars)}}. This is similar
+to the functionality provided by \code{\link[limma:removeBatchEffect]{limma::removeBatchEffect()}}, and is
+particularly useful for "removing" unwanted batch effects from
+log-gen-expression outcomes associated with technical variables (possibly
+without removing experimental design or grouping variables), but can be
+applied to any situation where variables need to be adjusted as part of
+pre-processing.
+
+(Prior to model fitting, numerical \code{remove_vars} / \code{keep_vars} are centered
+and factors are effect-encoded using \code{\link[stats:contr.sum]{stats::contr.sum()}}.)
+
+Note that the original data will be replaced with the adjusted data, possibly
+dropping the \code{remove_vars} / \code{keep_vars} (depending on the value of the \code{drop} argument).
+}
+\section{Tidying}{
+When you \code{\link[recipes:tidy.recipe]{tidy()}} this step, a tibble is returned with
+columns \code{variables}, \code{term}, \code{type}, \code{value}, and \code{id}:
+
+\describe{
+\item{variables}{character, the selectors or variables selected}
+\item{term}{character, the variables to remove or keep / coefficient label}
+\item{type}{character, either "remove" or "keep"}
+\item{value}{numeric, the coefficient value for the term}
+\item{id}{character, id of this step}
+}
+}
+
+\section{Case weights}{
+
+
+This step performs an supervised operation that can utilize case weights.
+To use them, see the documentation in \link[recipes:case_weights]{recipes::case_weights} and the examples on
+\code{tidymodels.org}.
+}
+
+\examples{
+\dontshow{if (rlang::is_installed(c("modeldata", "ggplot2"))) withAutoprint(\{ # examplesIf}
+
+library(ggplot2)
+
+data("penguins", package = "modeldata")
+penguins <- na.omit(penguins)
+
+p <- ggplot(penguins, aes(flipper_length_mm, body_mass_g, color = sex)) +
+ geom_point(aes(shape = species)) +
+ stat_ellipse() +
+ labs(title = "No adjustment")
+
+p
+
+
+recipe <- recipe(body_mass_g ~ ., data = penguins) |>
+ step_adjust_linear(
+ flipper_length_mm,
+ body_mass_g,
+ remove_vars = vars(species),
+ keep_vars = vars(sex),
+ drop = "none" # keep all variables in the baked data
+ )
+
+baked <- prep(recipe) |>
+ bake(new_data = penguins)
+
+ggplot2::ggplot_add(baked, p) +
+ labs(title = "Adjustment for species")
+
+\dontshow{\}) # examplesIf}
+}
diff --git a/tests/testthat/_snaps/adjust_linear.md b/tests/testthat/_snaps/adjust_linear.md
new file mode 100644
index 0000000..e29d8f9
--- /dev/null
+++ b/tests/testthat/_snaps/adjust_linear.md
@@ -0,0 +1,78 @@
+# bake method errors when needed non-standard role columns are missing
+
+ Code
+ bake(rec_trained, new_data = dat[, -2])
+ Condition
+ Error in `step_adjust_linear()`:
+ ! The following required column is missing from `new_data`: batch.
+
+# empty printing
+
+ Code
+ rec
+ Message
+
+ -- Recipe ----------------------------------------------------------------------
+
+ -- Inputs
+ Number of variables by role
+ outcome: 1
+ predictor: 10
+
+ -- Operations
+ * Linearly adjusting variables:
+
+---
+
+ Code
+ rec
+ Message
+
+ -- Recipe ----------------------------------------------------------------------
+
+ -- Inputs
+ Number of variables by role
+ outcome: 1
+ predictor: 10
+
+ -- Training information
+ Training data contained 32 data points and no incomplete rows.
+
+ -- Operations
+ * Linearly adjusting variables: | Trained
+
+# printing
+
+ Code
+ print(rec)
+ Message
+
+ -- Recipe ----------------------------------------------------------------------
+
+ -- Inputs
+ Number of variables by role
+ outcome: 1
+ predictor: 2
+
+ -- Operations
+ * Linearly adjusting variables: y
+
+---
+
+ Code
+ prep(rec)
+ Message
+
+ -- Recipe ----------------------------------------------------------------------
+
+ -- Inputs
+ Number of variables by role
+ outcome: 1
+ predictor: 2
+
+ -- Training information
+ Training data contained 6 data points and no incomplete rows.
+
+ -- Operations
+ * Linearly adjusting variables: y | Trained
+
diff --git a/tests/testthat/test-adjust_linear.R b/tests/testthat/test-adjust_linear.R
new file mode 100644
index 0000000..b376f66
--- /dev/null
+++ b/tests/testthat/test-adjust_linear.R
@@ -0,0 +1,323 @@
+rlang::local_options(lifecycle_verbosity = "quiet")
+
+test_that("step_adjust_linear adjusts (simple)", {
+ dat <- tibble::tibble(
+ y = 10:15,
+ batch = c(0, 0, 1, 1, 2, 2)
+ )
+
+ rec <- recipe(y ~ ., data = dat) |>
+ step_adjust_linear(y, remove_vars = vars(batch)) |>
+ prep(training = dat)
+
+ baked <- bake(rec, new_data = dat)
+ expect_identical(names(baked), "y")
+ expect_equal(unname(baked$y), rep(c(12, 13), times = 3), tolerance = 1e-6)
+})
+
+test_that("step_adjust_linear adjusts (complex)", {
+ data(mtcars)
+ mtcars$cyl <- factor(mtcars$cyl)
+
+ rec <- recipe(~., data = mtcars) |>
+ step_adjust_linear(
+ mpg,
+ remove_vars = vars(cyl, wt, hp),
+ keep_vars = vars(am)
+ ) |>
+ prep(training = mtcars)
+
+ baked <- bake(rec, new_data = mtcars)
+
+ mtcars_centered <- mtcars
+ mtcars_centered[, c("wt", "hp", "am")] <-
+ scale(
+ mtcars[, c("wt", "hp", "am")],
+ scale = FALSE
+ )
+
+ mod1 <- lm(
+ mpg ~ cyl + wt + hp + am,
+ contrasts = list(cyl = "contr.sum"),
+ data = mtcars_centered
+ )
+
+ expect_identical(
+ coef(rec$steps[[1]]$models$mpg),
+ coef(mod1),
+ ignore_attr = TRUE
+ )
+
+ expect_identical(
+ baked$mpg,
+ mtcars$mpg -
+ rowSums(predict(
+ mod1,
+ newdata = mtcars_centered,
+ type = "terms"
+ )[, 1:3]),
+
+ ignore_attr = TRUE
+ )
+})
+
+test_that("step_adjust_linear basic drop options", {
+ dat <- tibble::tibble(
+ y = c(10, 12, 14, 16, 18, 20),
+ z = c(5, 6, 7, 8, 9, 10),
+ batch = c(0, 0, 1, 1, 2, 2),
+ group = factor(c("a", "a", "a", "b", "b", "b"))
+ )
+
+ rec_remove <- recipe(y ~ ., data = dat) |>
+ step_adjust_linear(
+ y,
+ remove_vars = vars(batch),
+ keep_vars = vars(group),
+ drop = "remove"
+ ) |>
+ prep(training = dat)
+
+ baked_remove <- bake(rec_remove, new_data = dat)
+ expect_false("batch" %in% names(baked_remove))
+ expect_true("group" %in% names(baked_remove))
+ expect_false(isTRUE(all.equal(baked_remove$y, dat$y)))
+
+ rec_both <- recipe(y ~ ., data = dat) |>
+ step_adjust_linear(
+ y,
+ remove_vars = vars(batch),
+ keep_vars = vars(group),
+ drop = "both"
+ ) |>
+ prep(training = dat)
+
+ baked_both <- bake(rec_both, new_data = dat)
+ expect_false("batch" %in% names(baked_both))
+ expect_false("group" %in% names(baked_both))
+
+ rec_none <- recipe(y ~ ., data = dat) |>
+ step_adjust_linear(
+ y,
+ remove_vars = vars(batch),
+ keep_vars = vars(group),
+ drop = "none"
+ ) |>
+ prep(training = dat)
+
+ baked_none <- bake(rec_none, new_data = dat)
+ expect_true(all(c("batch", "group") %in% names(baked_none)))
+})
+
+test_that("step_adjust_linear can adjust multiple outcomes", {
+ dat <- tibble::tibble(
+ y = c(10, 12, 14, 16, 18, 20),
+ z = c(20, 21, 22, 23, 24, 25),
+ batch = c(0, 0, 1, 1, 2, 2),
+ group = factor(c("a", "a", "a", "b", "b", "b"))
+ )
+
+ rec <- recipe(~., data = dat) |>
+ step_adjust_linear(
+ y,
+ z,
+ remove_vars = vars(batch),
+ keep_vars = vars(group),
+ drop = "none"
+ ) |>
+ prep(training = dat)
+
+ baked <- bake(rec, new_data = dat)
+ expect_false(isTRUE(all.equal(baked$y, dat$y)))
+ expect_false(isTRUE(all.equal(baked$z, dat$z)))
+})
+
+test_that("step_adjust_linear validates arguments", {
+ dat <- tibble::tibble(
+ y = c(10, 12, 14, 16),
+ batch = c(0, 0, 1, 1),
+ group = factor(c("a", "a", "b", "b")),
+ bad = as.Date("2020-01-01") + 0:3
+ )
+
+ expect_error(
+ recipe(y ~ ., data = dat) |>
+ step_adjust_linear(y) |>
+ prep(training = dat),
+ "remove_vars"
+ )
+
+ expect_error(
+ recipe(y ~ ., data = dat) |>
+ step_adjust_linear(
+ y,
+ remove_vars = vars(batch, group),
+ keep_vars = vars(group)
+ ) |>
+ prep(training = dat),
+ "disjoint"
+ )
+
+ expect_error(
+ recipe(y ~ ., data = dat) |>
+ step_adjust_linear(y, remove_vars = vars(bad)) |>
+ prep(training = dat),
+ "either factors or numeric"
+ )
+})
+
+test_that("step_adjust_linear tidy works before and after prep", {
+ dat <- tibble::tibble(
+ y = c(10, 12, 14, 16, 18, 20),
+ batch = c(0, 0, 1, 1, 2, 2),
+ group = factor(c("a", "a", "a", "b", "b", "b"))
+ )
+
+ rec_untrained <- recipe(y ~ ., data = dat) |>
+ step_adjust_linear(
+ y,
+ remove_vars = vars(batch),
+ keep_vars = vars(group),
+ id = "adj"
+ )
+
+ td_untrained <- tidy(rec_untrained, number = 1)
+ expect_true(all(
+ c("variables", "term", "type", "value", "id") %in% names(td_untrained)
+ ))
+ expect_true(all(td_untrained$id == "adj"))
+
+ rec_trained <- prep(rec_untrained, training = dat)
+ td_trained <- tidy(rec_trained, number = 1)
+ expect_true(nrow(td_trained) > 0)
+ expect_true(all(c("remove", "keep") %in% unique(td_trained$type)))
+})
+
+test_that("step_adjust_linear bake errors when required columns are missing", {
+ dat <- tibble::tibble(
+ y = c(10, 12, 14, 16, 18, 20),
+ batch = c(0, 0, 1, 1, 2, 2),
+ group = factor(c("a", "a", "a", "b", "b", "b"))
+ )
+
+ rec <- recipe(y ~ ., data = dat) |>
+ step_adjust_linear(
+ y,
+ remove_vars = vars(batch),
+ keep_vars = vars(group),
+ drop = "none"
+ )
+
+ rec_trained <- prep(rec, training = dat, verbose = FALSE)
+
+ expect_error(
+ bake(rec_trained, new_data = dplyr::select(dat, -batch)),
+ "required"
+ )
+})
+
+test_that("step_adjust_linear can use case weights", {
+ skip_if_not_installed("hardhat")
+
+ dat <- tibble::tibble(
+ y = c(1, 2, 3, 6, 9, 30),
+ batch = c(0, 0, 1, 1, 2, 2),
+ wts = hardhat::importance_weights(c(1, 1, 1, 1, 1, 20))
+ )
+
+ rec_weighted <- recipe(y ~ ., data = dat) |>
+ step_adjust_linear(y, remove_vars = vars(batch), drop = "none") |>
+ prep(training = dat)
+
+ rec_unweighted <- recipe(y ~ ., data = dplyr::select(dat, -wts)) |>
+ step_adjust_linear(y, remove_vars = vars(batch), drop = "none") |>
+ prep(training = dplyr::select(dat, -wts))
+
+ baked_weighted <- bake(rec_weighted, new_data = dplyr::select(dat, -wts))
+ baked_unweighted <- bake(rec_unweighted, new_data = dplyr::select(dat, -wts))
+
+ expect_false(isTRUE(all.equal(baked_weighted$y, baked_unweighted$y)))
+})
+
+# Infrastructure ---------------------------------------------------------------
+
+test_that("bake method errors when needed non-standard role columns are missing", {
+ dat <- tibble::tibble(
+ y = c(10, 12, 14, 16, 18, 20),
+ batch = c(0, 0, 1, 1, 2, 2),
+ group = factor(c("a", "a", "a", "b", "b", "b"))
+ )
+
+ rec <- recipe(y ~ ., data = dat) |>
+ step_adjust_linear(
+ y,
+ remove_vars = vars(batch),
+ keep_vars = vars(group)
+ ) |>
+ update_role(batch, new_role = "potato") |>
+ update_role_requirements(role = "potato", bake = FALSE)
+
+ rec_trained <- prep(rec, training = dat, verbose = FALSE)
+
+ expect_snapshot(
+ error = TRUE,
+ bake(rec_trained, new_data = dat[, -2])
+ )
+})
+
+test_that("empty printing", {
+ rec <- recipe(mpg ~ ., mtcars)
+ rec <- step_adjust_linear(rec, remove_vars = vars(cyl))
+
+ expect_snapshot(rec)
+
+ rec <- prep(rec, mtcars)
+
+ expect_snapshot(rec)
+})
+
+test_that("empty selection prep/bake is a no-op", {
+ rec1 <- recipe(mpg ~ ., mtcars)
+ rec2 <- step_adjust_linear(rec1, remove_vars = vars(cyl), drop = "none")
+
+ rec1 <- prep(rec1, mtcars)
+ rec2 <- prep(rec2, mtcars)
+
+ baked1 <- bake(rec1, mtcars)
+ baked2 <- bake(rec2, mtcars)
+
+ expect_identical(baked1, baked2)
+})
+
+test_that("empty selection tidy method works", {
+ rec <- recipe(mpg ~ ., mtcars)
+ rec <- step_adjust_linear(rec, remove_vars = vars(cyl))
+
+ expect <- tibble::tibble(
+ variables = character(),
+ term = character(),
+ type = character(),
+ value = double(),
+ id = character()
+ )
+
+ expect_identical(tidy(rec, number = 1), expect)
+
+ rec <- prep(rec, mtcars)
+
+ expect_identical(tidy(rec, number = 1), expect)
+})
+
+test_that("printing", {
+ dat <- tibble::tibble(
+ y = c(10, 12, 14, 16, 18, 20),
+ batch = c(0, 0, 1, 1, 2, 2),
+ group = factor(c("a", "a", "a", "b", "b", "b"))
+ )
+
+ rec <- recipe(y ~ ., data = dat) |>
+ step_adjust_linear(y, remove_vars = vars(batch), keep_vars = vars(group))
+
+ expect_snapshot(print(rec))
+ expect_snapshot(prep(rec))
+})