From c231430408ce5a60681bb7fed185a17781368c0b Mon Sep 17 00:00:00 2001 From: Max Kuhn Date: Sun, 12 Apr 2026 15:56:00 -0400 Subject: [PATCH 1/4] a factor-to-feature mapping function --- NAMESPACE | 2 + NEWS.md | 2 + R/factor-key.R | 227 ++++++++++++++++ man/factor_key.Rd | 114 ++++++++ tests/testthat/_snaps/factor-key.md | 26 ++ tests/testthat/test-factor-key.R | 398 ++++++++++++++++++++++++++++ 6 files changed, 769 insertions(+) create mode 100644 R/factor-key.R create mode 100644 man/factor_key.Rd create mode 100644 tests/testthat/_snaps/factor-key.md create mode 100644 tests/testthat/test-factor-key.R diff --git a/NAMESPACE b/NAMESPACE index 20c158f2..c95f2991 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ S3method(as.matrix,quantile_pred) S3method(as_tibble,quantile_pred) +S3method(factor_key,terms) S3method(forge,data.frame) S3method(forge,default) S3method(forge,matrix) @@ -94,6 +95,7 @@ export(extract_recipe) export(extract_spec_parsnip) export(extract_tailor) export(extract_workflow) +export(factor_key) export(fct_encode_one_hot) export(forge) export(frequency_weights) diff --git a/NEWS.md b/NEWS.md index 46ef4df5..3c40f01e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # hardhat (development version) +* Added `factor_key()` to create mappings between original factor variables and their binary indicator columns in model matrices. This function helps understand how factors are encoded with different contrast methods, including support for interactions and nested effects. + # hardhat 1.4.3 * `mold()` no longer throws warnings about `strings_as_factors` argument when used on recipe objects (#284). diff --git a/R/factor-key.R b/R/factor-key.R new file mode 100644 index 00000000..a58d9ee9 --- /dev/null +++ b/R/factor-key.R @@ -0,0 +1,227 @@ +#' Map factor variables to their numeric features +#' +#' @description +#' `factor_key()` creates a mapping between original factor variables and +#' their corresponding numeric features (e.g., binary indicator columns, etc.) +#' generated in a model matrix. +#' +#' @param x An object. For the default method, a terms object. +#' @param ... Arguments passed to methods. +#' +#' @return +#' A tibble with two columns: +#' \describe{ +#' \item{`source`}{The name of the original factor variable} +#' \item{`derived`}{The name of the generated model matrix column} +#' } +#' +#' For interaction terms, multiple rows are returned with each source +#' factor mapped to the interaction column. +#' +#' Returns an empty tibble with the correct columns if no factors are present +#' in the terms. +#' +#' @details +#' +#' This function helps you understand how R's model matrix construction +#' converts factor variables into multiple features. It handles: +#' +#' - **Contrast types**: Different contrast methods (treatment, sum, helmert, +#' polynomial, one-hot) produce different column naming patterns +#' - **Ordered factors**: These typically use polynomial contrasts, creating +#' columns with `.L` (linear), `.Q` (quadratic), `.C` (cubic) suffixes +#' - **Interactions**: Interaction terms like `A:B` will have multiple rows in +#' the output, one for each contributing factor +#' - **Nested effects**: Terms like `A/B` (which expands to `A + A:B`) are +#' properly handled, with the nested interaction mapped to both source factors +#' +#' The function uses the same model matrix generation as [model_matrix()], +#' ensuring consistency with how your models will actually be fit. +#' +#' @examples +#' # --------------------------------------------------------------------------- +#' # Simple factor with treatment contrasts (default) +#' +#' framed <- model_frame(Sepal.Width ~ Species, iris) +#' factor_key(framed$terms, framed$data) +#' +#' # --------------------------------------------------------------------------- +#' # Ordered factor with polynomial contrasts +#' +#' mtcars2 <- mtcars +#' mtcars2$gear_ord <- ordered(mtcars2$gear) +#' framed <- model_frame(mpg ~ gear_ord, mtcars2) +#' factor_key(framed$terms, framed$data) +#' +#' # --------------------------------------------------------------------------- +#' # Interaction between two factors +#' +#' mtcars2 <- mtcars +#' mtcars2$cyl_fct <- factor(mtcars2$cyl) +#' mtcars2$am_fct <- factor(mtcars2$am) +#' framed <- model_frame(mpg ~ cyl_fct * am_fct, mtcars2) +#' factor_key(framed$terms, framed$data) +#' +#' # --------------------------------------------------------------------------- +#' # Nested effects (gear nested within cyl) +#' +#' mtcars2 <- mtcars +#' mtcars2$cyl_fct <- factor(mtcars2$cyl) +#' mtcars2$gear_fct <- factor(mtcars2$gear) +#' framed <- model_frame(mpg ~ cyl_fct / gear_fct, mtcars2) +#' # This expands to: mpg ~ cyl_fct + cyl_fct:gear_fct +#' factor_key(framed$terms, framed$data) +#' +#' # --------------------------------------------------------------------------- +#' # No factors returns empty tibble +#' +#' framed <- model_frame(Sepal.Width ~ Sepal.Length + Petal.Width, iris) +#' factor_key(framed$terms, framed$data) +#' +#' # --------------------------------------------------------------------------- +#' # Custom contrasts +#' +#' species_sum <- iris$Species +#' contrasts(species_sum) <- contr.sum(3) +#' iris2 <- iris +#' iris2$Species <- species_sum +#' +#' framed <- model_frame(Sepal.Width ~ Species, iris2) +#' factor_key(framed$terms, framed$data) +#' +#' @seealso +#' - [model_matrix()] for generating the design matrix +#' - [get_levels()] for extracting factor levels +#' - [stats::contrasts()] for setting contrast methods +#' +#' @export +factor_key <- function(x, ...) { + UseMethod("factor_key") +} + +#' @param data A data frame or tibble containing the variables in `x`. +#' @inheritParams validate_column_names +#' +#' @rdname factor_key +#' @export +factor_key.terms <- function(x, data, ..., call = current_env()) { + check_dots_empty0(...) + check_terms(x, call = call) + check_data_frame_or_matrix(data, call = call) + data <- coerce_to_tibble(data) + + # Get the data classes from the terms to identify factors + data_classes <- attr(x, "dataClasses") + + # If no dataClasses attribute, try to infer from the data + if (is.null(data_classes)) { + # Get variable names from the terms + term_vars <- all.vars(x) + data_classes <- vapply( + term_vars, + get_first_class, + character(1), + data = data + ) + names(data_classes) <- term_vars + } + + # Identify factor and ordered variables + # Note: "ordered" is a subclass of "factor" but stored separately in dataClasses + factor_vars <- names(data_classes)[data_classes %in% c("factor", "ordered", "character")] + + # If no factors, return empty tibble with correct structure + if (length(factor_vars) == 0) { + return(tibble::tibble(source = character(), derived = character())) + } + + # Generate the model matrix to get actual column names + # Use with_na_pass to handle missing values properly + # Also wrap in tryCatch to handle single-level factors gracefully + mm <- tryCatch( + { + with_na_pass(model.matrix(x, data)) + }, + error = function(e) { + # Check if it's the single-level factor error + if (grepl("contrasts can be applied only to factors with 2 or more levels", e$message)) { + # Return NULL to indicate no model matrix could be created + return(NULL) + } + # Re-throw other errors + stop(e) + } + ) + + # If model matrix couldn't be created (e.g., single-level factors), return empty tibble + if (is.null(mm)) { + return(tibble::tibble(source = character(), derived = character())) + } + + # Get the assign attribute which maps columns to term indices + assign_attr <- attr(mm, "assign") + mm_colnames <- colnames(mm) + + # Get the factors matrix from terms (shows which variables contribute to each term) + factors_matrix <- attr(x, "factors") + + # If no factors matrix (e.g., intercept-only model), return empty tibble + if (is.null(factors_matrix)) { + return(tibble::tibble(source = character(), derived = character())) + } + + # Get term labels + term_labels <- attr(x, "term.labels") + + # Build mapping data + mapping_list <- list() + + for (i in seq_along(mm_colnames)) { + col_name <- mm_colnames[i] + term_index <- assign_attr[i] + + # Skip intercept (term_index == 0) + if (term_index == 0) { + next + } + + # Get the term label + term_label <- term_labels[term_index] + + # Find which variables contribute to this term + contributing_vars <- rownames(factors_matrix)[factors_matrix[, term_index] > 0] + + # Filter to only factor variables + factor_contributors <- intersect(contributing_vars, factor_vars) + + # If this column has factor contributors, add to mapping + if (length(factor_contributors) > 0) { + for (factor_var in factor_contributors) { + mapping_list[[length(mapping_list) + 1]] <- data.frame( + source = factor_var, + derived = col_name, + stringsAsFactors = FALSE + ) + } + } + } + + # Combine all mappings into a single data frame + if (length(mapping_list) > 0) { + result <- do.call(rbind, mapping_list) + result <- tibble::as_tibble(result) + } else { + result <- tibble::tibble(source = character(), derived = character()) + } + + result +} + +# Helper function to get the first class of a variable +get_first_class <- function(var, data) { + if (var %in% names(data)) { + return(class(data[[var]])[1]) + } else { + return("unknown") + } +} diff --git a/man/factor_key.Rd b/man/factor_key.Rd new file mode 100644 index 00000000..17fa55f4 --- /dev/null +++ b/man/factor_key.Rd @@ -0,0 +1,114 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/factor-key.R +\name{factor_key} +\alias{factor_key} +\alias{factor_key.terms} +\title{Map factor variables to their numeric features} +\usage{ +factor_key(x, ...) + +\method{factor_key}{terms}(x, data, ..., call = current_env()) +} +\arguments{ +\item{x}{An object. For the default method, a terms object.} + +\item{...}{Arguments passed to methods.} + +\item{data}{A data frame or tibble containing the variables in \code{x}.} + +\item{call}{The call used for errors and warnings.} +} +\value{ +A tibble with two columns: +\describe{ +\item{\code{source}}{The name of the original factor variable} +\item{\code{derived}}{The name of the generated model matrix column} +} + +For interaction terms, multiple rows are returned with each source +factor mapped to the interaction column. + +Returns an empty tibble with the correct columns if no factors are present +in the terms. +} +\description{ +\code{factor_key()} creates a mapping between original factor variables and +their corresponding numeric features (e.g., binary indicator columns, etc.) +generated in a model matrix. +} +\details{ +This function helps you understand how R's model matrix construction +converts factor variables into multiple features. It handles: +\itemize{ +\item \strong{Contrast types}: Different contrast methods (treatment, sum, helmert, +polynomial, one-hot) produce different column naming patterns +\item \strong{Ordered factors}: These typically use polynomial contrasts, creating +columns with \code{.L} (linear), \code{.Q} (quadratic), \code{.C} (cubic) suffixes +\item \strong{Interactions}: Interaction terms like \code{A:B} will have multiple rows in +the output, one for each contributing factor +\item \strong{Nested effects}: Terms like \code{A/B} (which expands to \code{A + A:B}) are +properly handled, with the nested interaction mapped to both source factors +} + +The function uses the same model matrix generation as \code{\link[=model_matrix]{model_matrix()}}, +ensuring consistency with how your models will actually be fit. +} +\examples{ +# --------------------------------------------------------------------------- +# Simple factor with treatment contrasts (default) + +framed <- model_frame(Sepal.Width ~ Species, iris) +factor_key(framed$terms, framed$data) + +# --------------------------------------------------------------------------- +# Ordered factor with polynomial contrasts + +mtcars2 <- mtcars +mtcars2$gear_ord <- ordered(mtcars2$gear) +framed <- model_frame(mpg ~ gear_ord, mtcars2) +factor_key(framed$terms, framed$data) + +# --------------------------------------------------------------------------- +# Interaction between two factors + +mtcars2 <- mtcars +mtcars2$cyl_fct <- factor(mtcars2$cyl) +mtcars2$am_fct <- factor(mtcars2$am) +framed <- model_frame(mpg ~ cyl_fct * am_fct, mtcars2) +factor_key(framed$terms, framed$data) + +# --------------------------------------------------------------------------- +# Nested effects (gear nested within cyl) + +mtcars2 <- mtcars +mtcars2$cyl_fct <- factor(mtcars2$cyl) +mtcars2$gear_fct <- factor(mtcars2$gear) +framed <- model_frame(mpg ~ cyl_fct / gear_fct, mtcars2) +# This expands to: mpg ~ cyl_fct + cyl_fct:gear_fct +factor_key(framed$terms, framed$data) + +# --------------------------------------------------------------------------- +# No factors returns empty tibble + +framed <- model_frame(Sepal.Width ~ Sepal.Length + Petal.Width, iris) +factor_key(framed$terms, framed$data) + +# --------------------------------------------------------------------------- +# Custom contrasts + +species_sum <- iris$Species +contrasts(species_sum) <- contr.sum(3) +iris2 <- iris +iris2$Species <- species_sum + +framed <- model_frame(Sepal.Width ~ Species, iris2) +factor_key(framed$terms, framed$data) + +} +\seealso{ +\itemize{ +\item \code{\link[=model_matrix]{model_matrix()}} for generating the design matrix +\item \code{\link[=get_levels]{get_levels()}} for extracting factor levels +\item \code{\link[stats:contrasts]{stats::contrasts()}} for setting contrast methods +} +} diff --git a/tests/testthat/_snaps/factor-key.md b/tests/testthat/_snaps/factor-key.md new file mode 100644 index 00000000..f27b505b --- /dev/null +++ b/tests/testthat/_snaps/factor-key.md @@ -0,0 +1,26 @@ +# factor_key validates inputs correctly + + Code + factor_key("not_terms", framed$data) + Condition + Error in `factor_key()`: + ! `terms` must be a , not the string "not_terms". + +--- + + Code + factor_key(framed$terms, "not_data") + Condition + Error in `factor_key()`: + ! `data` must be a data frame or a matrix, not the string "not_data". + +--- + + Code + factor_key(framed$terms, framed$data, extra = "arg") + Condition + Error in `factor_key()`: + ! `...` must be empty. + x Problematic argument: + * extra = "arg" + diff --git a/tests/testthat/test-factor-key.R b/tests/testthat/test-factor-key.R new file mode 100644 index 00000000..ff233e41 --- /dev/null +++ b/tests/testthat/test-factor-key.R @@ -0,0 +1,398 @@ +test_that("factor_key works with simple factor", { + # Single factor with default treatment contrasts + df <- data.frame( + y = 1:9, + f1 = factor(rep(c("a", "b", "c"), 3)) + ) + framed <- model_frame(y ~ f1, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_identical(colnames(result), c("source", "derived")) + expect_equal(nrow(result), 2) # 3 levels - 1 reference = 2 columns + expect_true(all(result$source == "f1")) + expect_equal(sort(result$derived), c("f1b", "f1c")) +}) + +test_that("factor_key works with multiple factors", { + df <- data.frame( + y = 1:12, + f1 = factor(rep(c("a", "b"), 6)), + f2 = factor(rep(c("x", "y", "z"), 4)) + ) + framed <- model_frame(y ~ f1 + f2, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_equal(nrow(result), 3) # 1 from f1 (2-1) + 2 from f2 (3-1) + expect_equal(sum(result$source == "f1"), 1) + expect_equal(sum(result$source == "f2"), 2) +}) + +test_that("factor_key works with ordered factors", { + df <- data.frame( + y = 1:12, + ord = ordered(rep(c("low", "med", "high"), 4)) + ) + framed <- model_frame(y ~ ord, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_equal(nrow(result), 2) # Linear and quadratic for 3 levels + expect_true(all(result$source == "ord")) + # Ordered factors use polynomial contrasts by default + expect_true(all(grepl("\\.(L|Q)", result$derived))) +}) + +test_that("factor_key returns empty tibble when no factors", { + df <- data.frame( + y = 1:10, + x1 = rnorm(10), + x2 = rnorm(10) + ) + framed <- model_frame(y ~ x1 + x2, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_identical(colnames(result), c("source", "derived")) + expect_equal(nrow(result), 0) +}) + +test_that("factor_key works with two-way interactions", { + df <- data.frame( + y = 1:12, + f1 = factor(rep(c("a", "b"), 6)), + f2 = factor(rep(c("x", "y", "z"), 4)) + ) + framed <- model_frame(y ~ f1 * f2, df) + result <- factor_key(framed$terms, framed$data) + + # Should have main effects and interactions + expect_s3_class(result, "tbl_df") + + # Main effects: 1 from f1, 2 from f2 + # Interactions: 1*2 = 2 columns, each mapped to both factors + # Total rows: 1 + 2 + 2*2 = 7 + expect_equal(nrow(result), 7) + + # Check interaction columns are mapped to both factors + interaction_cols <- result$derived[grepl(":", result$derived)] + expect_true(length(interaction_cols) > 0) + + for (int_col in unique(interaction_cols)) { + sources <- result$source[result$derived == int_col] + expect_equal(length(sources), 2) + expect_true("f1" %in% sources) + expect_true("f2" %in% sources) + } +}) + +test_that("factor_key works with factor x numeric interactions", { + df <- data.frame( + y = 1:10, + f1 = factor(rep(c("a", "b"), 5)), + x = rnorm(10) + ) + framed <- model_frame(y ~ f1 * x, df) + result <- factor_key(framed$terms, framed$data) + + # Main effect of f1 (1 column) + interaction f1:x (1 column, only f1 as source) + # Note: numeric main effect x is not included + expect_s3_class(result, "tbl_df") + expect_equal(nrow(result), 2) + expect_true(all(result$source == "f1")) + + # One should be main effect, one should be interaction + expect_true(any(!grepl(":", result$derived))) # Main effect + expect_true(any(grepl(":", result$derived))) # Interaction +}) + +test_that("factor_key works with three-way interactions", { + df <- data.frame( + y = 1:24, + f1 = factor(rep(c("a", "b"), 12)), + f2 = factor(rep(c("x", "y"), 12)), + f3 = factor(rep(c("m", "n"), 12)) + ) + framed <- model_frame(y ~ f1 * f2 * f3, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + + # Check three-way interaction is mapped to all three factors + three_way_cols <- result$derived[grepl(".*:.*:.*", result$derived)] + expect_true(length(three_way_cols) > 0) + + for (col in unique(three_way_cols)) { + sources <- result$source[result$derived == col] + expect_equal(length(sources), 3) + expect_true(all(c("f1", "f2", "f3") %in% sources)) + } +}) + +test_that("factor_key works with nested effects", { + df <- data.frame( + y = rnorm(24), + A = factor(rep(c("a1", "a2"), each = 12)), + B = factor(rep(c("b1", "b2", "b3"), 8)) + ) + + # A/B expands to A + A:B + framed <- model_frame(y ~ A / B, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + + # Should have main effect of A and A:B interaction + # Main effect A: 1 column (Aa2) + # A:B interaction: 4 columns (Aa1:Bb2, Aa2:Bb2, Aa1:Bb3, Aa2:Bb3) + # Each interaction column is mapped to both A and B + # Total rows: 1 + 4*2 = 9 + expect_equal(nrow(result), 9) + + # Check main effect of A + main_effect <- result[!grepl(":", result$derived), ] + expect_equal(nrow(main_effect), 1) + expect_equal(main_effect$source, "A") + + # Check nested effect A:B + nested_effect <- result[grepl(":", result$derived), ] + expect_equal(nrow(nested_effect), 8) # 4 columns * 2 sources each + # Each interaction column should be mapped to both A and B + for (col in unique(nested_effect$derived)) { + sources <- nested_effect$source[nested_effect$derived == col] + expect_equal(length(sources), 2) + expect_true(all(c("A", "B") %in% sources)) + } +}) + +test_that("factor_key works with different contrast types", { + df <- data.frame( + y = 1:9, + f1 = factor(rep(c("a", "b", "c"), 3)) + ) + + # Sum contrasts + f_sum <- df$f1 + contrasts(f_sum) <- contr.sum(3) + df_sum <- df + df_sum$f1 <- f_sum + + framed <- model_frame(y ~ f1, df_sum) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_equal(nrow(result), 2) # Sum contrasts: k-1 columns + expect_true(all(result$source == "f1")) + + # Helmert contrasts + f_helm <- df$f1 + contrasts(f_helm) <- contr.helmert(3) + df_helm <- df + df_helm$f1 <- f_helm + + framed <- model_frame(y ~ f1, df_helm) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_equal(nrow(result), 2) # Helmert contrasts: k-1 columns + expect_true(all(result$source == "f1")) +}) + +test_that("factor_key works with one-hot encoding", { + # Skip if contr_one_hot is not available + if (!exists("contr_one_hot", mode = "function")) { + skip("contr_one_hot not available") + } + + df <- data.frame( + y = 1:9, + f1 = factor(rep(c("a", "b", "c"), 3)) + ) + + f_onehot <- df$f1 + contrasts(f_onehot) <- contr_one_hot(3) + df_onehot <- df + df_onehot$f1 <- f_onehot + + framed <- model_frame(y ~ f1 - 1, df_onehot) # Remove intercept for one-hot + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_equal(nrow(result), 3) # One-hot: k columns (all levels) + expect_true(all(result$source == "f1")) +}) + +test_that("factor_key handles factors with unusual level names", { + df <- data.frame( + y = 1:9, + f1 = factor(rep(c("level 1", "level-2", "level.3"), 3)) + ) + framed <- model_frame(y ~ f1, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_equal(nrow(result), 2) + expect_true(all(result$source == "f1")) + # Check that derived names are properly formatted + expect_true(all(nchar(result$derived) > 0)) +}) + +test_that("factor_key handles single-level factors", { + df <- data.frame( + y = 1:5, + f1 = factor(rep("a", 5)) + ) + framed <- model_frame(y ~ f1, df) + + # Single-level factors don't generate any columns in model matrix + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_identical(colnames(result), c("source", "derived")) + expect_equal(nrow(result), 0) # No columns generated for single-level factor +}) + +test_that("factor_key handles missing values appropriately", { + df <- data.frame( + y = c(1:8, NA, 10), + f1 = factor(c("a", "b", "a", "b", "a", "b", NA, "b", "a", "b")) + ) + framed <- model_frame(y ~ f1, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_identical(colnames(result), c("source", "derived")) + # Should still map the factor despite NAs in data + expect_equal(nrow(result), 1) + expect_equal(result$source, "f1") +}) + +test_that("factor_key handles empty data frame", { + df <- data.frame( + y = numeric(0), + f1 = factor(character(0), levels = c("a", "b")) + ) + framed <- model_frame(y ~ f1, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_identical(colnames(result), c("source", "derived")) + # With empty data, model.matrix still generates column structure + expect_equal(nrow(result), 1) +}) + +test_that("factor_key handles intercept-only models", { + df <- data.frame( + y = 1:10, + f1 = factor(rep(c("a", "b"), 5)) + ) + framed <- model_frame(y ~ 1, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + expect_identical(colnames(result), c("source", "derived")) + expect_equal(nrow(result), 0) # No factors in the formula +}) + +test_that("factor_key validates inputs correctly", { + df <- data.frame(y = 1:5, f1 = factor(c("a", "b", "a", "b", "a"))) + framed <- model_frame(y ~ f1, df) + + # Invalid terms + expect_snapshot(error = TRUE, { + factor_key("not_terms", framed$data) + }) + + # Invalid data + expect_snapshot(error = TRUE, { + factor_key(framed$terms, "not_data") + }) + + # Non-empty dots + expect_snapshot(error = TRUE, { + factor_key(framed$terms, framed$data, extra = "arg") + }) +}) + +test_that("factor_key works with character variables treated as factors", { + df <- data.frame( + y = 1:6, + chr = c("a", "b", "c", "a", "b", "c"), + stringsAsFactors = FALSE + ) + framed <- model_frame(y ~ chr, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + # Character variables are coerced to factors in model.matrix + expect_true(nrow(result) > 0) + expect_true(all(result$source == "chr")) +}) + +test_that("factor_key handles complex nested structures", { + # Multiple levels of nesting: A/B/C + df <- data.frame( + y = rnorm(48), + A = factor(rep(c("a1", "a2"), each = 24)), + B = factor(rep(c("b1", "b2", "b3", "b4"), each = 6, times = 2)), + C = factor(rep(c("c1", "c2"), 24)) + ) + + # A/B/C expands to A + A:B + A:B:C + framed <- model_frame(y ~ A / B / C, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + + # Check we have mappings for all terms + # Main effect A + main_a <- result[result$derived %in% result$derived[!grepl(":", result$derived)], ] + expect_true(nrow(main_a) > 0) + + # A:B interaction + ab_int <- result[grepl("^[^:]+:[^:]+$", result$derived), ] + expect_true(nrow(ab_int) > 0) + + # A:B:C interaction + abc_int <- result[grepl(".*:.*:.*", result$derived), ] + expect_true(nrow(abc_int) > 0) +}) + +test_that("factor_key preserves factor ordering in output", { + df <- data.frame( + y = 1:12, + f1 = factor(rep(c("z", "a", "m"), 4)), + f2 = factor(rep(c("b", "w"), 6)) + ) + framed <- model_frame(y ~ f1 + f2, df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + # The derived column names should match what model.matrix produces + mm <- model.matrix(framed$terms, framed$data) + mm_cols <- colnames(mm)[colnames(mm) != "(Intercept)"] + + expect_true(all(result$derived %in% mm_cols)) +}) + +test_that("factor_key works with formula containing dots", { + # When . is used in formula, it should be expanded first + df <- data.frame( + y = 1:12, + f1 = factor(rep(c("a", "b"), 6)), + f2 = factor(rep(c("x", "y", "z"), 4)), + x = rnorm(12) + ) + + # First expand the formula with model.frame + framed <- model_frame(y ~ ., df) + result <- factor_key(framed$terms, framed$data) + + expect_s3_class(result, "tbl_df") + # Should find both f1 and f2 + expect_true("f1" %in% result$source) + expect_true("f2" %in% result$source) + # But not x (numeric) + expect_false("x" %in% result$source) +}) From effa152d0ce388a29f903835766957dd97d0d2c1 Mon Sep 17 00:00:00 2001 From: Max Kuhn Date: Sun, 12 Apr 2026 16:40:00 -0400 Subject: [PATCH 2/4] add blueprint methods --- NAMESPACE | 6 + R/factor-key.R | 175 +++++++++++++++++++----- man/factor_key.Rd | 116 +++++++++++----- tests/testthat/_snaps/factor-key.md | 14 +- tests/testthat/test-factor-key.R | 204 ++++++++++++++++++++++++---- 5 files changed, 412 insertions(+), 103 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c95f2991..8d89d42e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,7 +2,13 @@ S3method(as.matrix,quantile_pred) S3method(as_tibble,quantile_pred) +S3method(factor_key,default_formula_blueprint) +S3method(factor_key,default_recipe_blueprint) +S3method(factor_key,default_xy_blueprint) +S3method(factor_key,formula_blueprint) +S3method(factor_key,recipe_blueprint) S3method(factor_key,terms) +S3method(factor_key,xy_blueprint) S3method(forge,data.frame) S3method(forge,default) S3method(forge,matrix) diff --git a/R/factor-key.R b/R/factor-key.R index a58d9ee9..6eb2881a 100644 --- a/R/factor-key.R +++ b/R/factor-key.R @@ -39,54 +39,76 @@ #' ensuring consistency with how your models will actually be fit. #' #' @examples -#' # --------------------------------------------------------------------------- -#' # Simple factor with treatment contrasts (default) +#' if (rlang::is_installed("modeldata")) { +#' library(modeldata) #' -#' framed <- model_frame(Sepal.Width ~ Species, iris) -#' factor_key(framed$terms, framed$data) +#' # --------------------------------------------------------------------------- +#' # Simple factor with treatment contrasts (default) #' -#' # --------------------------------------------------------------------------- -#' # Ordered factor with polynomial contrasts +#' data(penguins) +#' framed <- model_frame(bill_length_mm ~ species, penguins) +#' factor_key(framed$terms, framed$data) #' -#' mtcars2 <- mtcars -#' mtcars2$gear_ord <- ordered(mtcars2$gear) -#' framed <- model_frame(mpg ~ gear_ord, mtcars2) -#' factor_key(framed$terms, framed$data) +#' # --------------------------------------------------------------------------- +#' # Multiple factors #' -#' # --------------------------------------------------------------------------- -#' # Interaction between two factors +#' data(credit_data) +#' framed <- model_frame(Income ~ Home + Job, credit_data) +#' factor_key(framed$terms, framed$data) #' -#' mtcars2 <- mtcars -#' mtcars2$cyl_fct <- factor(mtcars2$cyl) -#' mtcars2$am_fct <- factor(mtcars2$am) -#' framed <- model_frame(mpg ~ cyl_fct * am_fct, mtcars2) -#' factor_key(framed$terms, framed$data) +#' # --------------------------------------------------------------------------- +#' # Interaction between two factors #' -#' # --------------------------------------------------------------------------- -#' # Nested effects (gear nested within cyl) +#' framed <- model_frame(bill_length_mm ~ species * island, penguins) +#' factor_key(framed$terms, framed$data) #' -#' mtcars2 <- mtcars -#' mtcars2$cyl_fct <- factor(mtcars2$cyl) -#' mtcars2$gear_fct <- factor(mtcars2$gear) -#' framed <- model_frame(mpg ~ cyl_fct / gear_fct, mtcars2) -#' # This expands to: mpg ~ cyl_fct + cyl_fct:gear_fct -#' factor_key(framed$terms, framed$data) +#' # --------------------------------------------------------------------------- +#' # Nested effects (Job nested within Home) #' -#' # --------------------------------------------------------------------------- -#' # No factors returns empty tibble +#' framed <- model_frame(Income ~ Home / Job, credit_data) +#' # This expands to: Income ~ Home + Home:Job +#' factor_key(framed$terms, framed$data) #' -#' framed <- model_frame(Sepal.Width ~ Sepal.Length + Petal.Width, iris) -#' factor_key(framed$terms, framed$data) +#' # --------------------------------------------------------------------------- +#' # No factors returns empty tibble #' -#' # --------------------------------------------------------------------------- -#' # Custom contrasts +#' data(concrete) +#' framed <- model_frame(compressive_strength ~ cement + water, concrete) +#' factor_key(framed$terms, framed$data) +#' +#' # --------------------------------------------------------------------------- +#' # Custom contrasts #' -#' species_sum <- iris$Species -#' contrasts(species_sum) <- contr.sum(3) -#' iris2 <- iris -#' iris2$Species <- species_sum +#' penguins2 <- penguins +#' species_sum <- penguins2$species +#' contrasts(species_sum) <- contr.sum(3) +#' penguins2$species <- species_sum #' -#' framed <- model_frame(Sepal.Width ~ Species, iris2) +#' framed <- model_frame(bill_length_mm ~ species, penguins2) +#' factor_key(framed$terms, framed$data) +#' +#' # --------------------------------------------------------------------------- +#' # Using with blueprints from mold() +#' +#' # Formula blueprint +#' molded <- mold(bill_length_mm ~ species + island, penguins) +#' factor_key(molded$blueprint, penguins) +#' +#' # XY blueprint (returns empty tibble since no terms/factors) +#' bp_xy <- default_xy_blueprint() +#' molded_xy <- mold(penguins[c("species", "island")], +#' penguins["bill_length_mm"], +#' blueprint = bp_xy) +#' factor_key(molded_xy$blueprint) +#' } +#' +#' # --------------------------------------------------------------------------- +#' # Ordered factor with polynomial contrasts +#' +#' data(mtcars) +#' mtcars2 <- mtcars +#' mtcars2$gear_ord <- ordered(mtcars2$gear) +#' framed <- model_frame(mpg ~ gear_ord, mtcars2) #' factor_key(framed$terms, framed$data) #' #' @seealso @@ -225,3 +247,84 @@ get_first_class <- function(var, data) { return("unknown") } } + +# ------------------------------------------------------------------------------ +# Blueprint methods + +#' @param data A data frame or tibble containing the variables used during +#' model fitting. Required for blueprint methods since blueprints don't +#' store the original data. +#' +#' @rdname factor_key +#' @export +factor_key.default_formula_blueprint <- function(x, data, ..., call = current_env()) { + check_dots_empty0(...) + + # Extract the predictors terms from the blueprint + terms_obj <- x$terms$predictors + + if (is.null(terms_obj)) { + cli::cli_abort("Blueprint does not contain terms for predictors.", call = call) + } + + # Call the terms method + factor_key.terms(terms_obj, data, call = call) +} + +#' @rdname factor_key +#' @export +factor_key.formula_blueprint <- function(x, data, ..., call = current_env()) { + # Fallback for non-default formula blueprints + # Try to extract terms if available, otherwise error + check_dots_empty0(...) + + if (!is.null(x$terms) && !is.null(x$terms$predictors)) { + factor_key.terms(x$terms$predictors, data, call = call) + } else { + cli::cli_abort( + "Cannot extract factor mappings from this formula blueprint type.", + call = call + ) + } +} + +#' @rdname factor_key +#' @export +factor_key.default_recipe_blueprint <- function(x, data = NULL, ..., call = current_env()) { + check_dots_empty0(...) + + # Recipes handle factors differently - they may encode them during prep + # For now, return a message indicating this isn't directly supported + cli::cli_abort( + c( + "factor_key() is not yet implemented for recipe blueprints.", + "i" = "Recipes handle factor encoding during the prep step.", + "i" = "Consider using a formula blueprint if you need factor mappings." + ), + call = call + ) +} + +#' @rdname factor_key +#' @export +factor_key.recipe_blueprint <- function(x, data = NULL, ..., call = current_env()) { + # Fallback for non-default recipe blueprints + factor_key.default_recipe_blueprint(x, data, ..., call = call) +} + +#' @rdname factor_key +#' @export +factor_key.default_xy_blueprint <- function(x, data = NULL, ..., call = current_env()) { + check_dots_empty0(...) + + # XY blueprints don't use terms or formulas, so there's no factor encoding to map + # Return empty tibble to be consistent with no-factors case + tibble::tibble(source = character(), derived = character()) +} + +#' @rdname factor_key +#' @export +factor_key.xy_blueprint <- function(x, data = NULL, ..., call = current_env()) { + # Fallback for non-default XY blueprints + factor_key.default_xy_blueprint(x, data, ..., call = call) +} diff --git a/man/factor_key.Rd b/man/factor_key.Rd index 17fa55f4..c8a98f5f 100644 --- a/man/factor_key.Rd +++ b/man/factor_key.Rd @@ -3,18 +3,38 @@ \name{factor_key} \alias{factor_key} \alias{factor_key.terms} +\alias{factor_key.default_formula_blueprint} +\alias{factor_key.formula_blueprint} +\alias{factor_key.default_recipe_blueprint} +\alias{factor_key.recipe_blueprint} +\alias{factor_key.default_xy_blueprint} +\alias{factor_key.xy_blueprint} \title{Map factor variables to their numeric features} \usage{ factor_key(x, ...) \method{factor_key}{terms}(x, data, ..., call = current_env()) + +\method{factor_key}{default_formula_blueprint}(x, data, ..., call = current_env()) + +\method{factor_key}{formula_blueprint}(x, data, ..., call = current_env()) + +\method{factor_key}{default_recipe_blueprint}(x, data = NULL, ..., call = current_env()) + +\method{factor_key}{recipe_blueprint}(x, data = NULL, ..., call = current_env()) + +\method{factor_key}{default_xy_blueprint}(x, data = NULL, ..., call = current_env()) + +\method{factor_key}{xy_blueprint}(x, data = NULL, ..., call = current_env()) } \arguments{ \item{x}{An object. For the default method, a terms object.} \item{...}{Arguments passed to methods.} -\item{data}{A data frame or tibble containing the variables in \code{x}.} +\item{data}{A data frame or tibble containing the variables used during +model fitting. Required for blueprint methods since blueprints don't +store the original data.} \item{call}{The call used for errors and warnings.} } @@ -54,54 +74,76 @@ The function uses the same model matrix generation as \code{\link[=model_matrix] ensuring consistency with how your models will actually be fit. } \examples{ -# --------------------------------------------------------------------------- -# Simple factor with treatment contrasts (default) +if (rlang::is_installed("modeldata")) { + library(modeldata) -framed <- model_frame(Sepal.Width ~ Species, iris) -factor_key(framed$terms, framed$data) + # --------------------------------------------------------------------------- + # Simple factor with treatment contrasts (default) -# --------------------------------------------------------------------------- -# Ordered factor with polynomial contrasts + data(penguins) + framed <- model_frame(bill_length_mm ~ species, penguins) + factor_key(framed$terms, framed$data) -mtcars2 <- mtcars -mtcars2$gear_ord <- ordered(mtcars2$gear) -framed <- model_frame(mpg ~ gear_ord, mtcars2) -factor_key(framed$terms, framed$data) + # --------------------------------------------------------------------------- + # Multiple factors -# --------------------------------------------------------------------------- -# Interaction between two factors + data(credit_data) + framed <- model_frame(Income ~ Home + Job, credit_data) + factor_key(framed$terms, framed$data) -mtcars2 <- mtcars -mtcars2$cyl_fct <- factor(mtcars2$cyl) -mtcars2$am_fct <- factor(mtcars2$am) -framed <- model_frame(mpg ~ cyl_fct * am_fct, mtcars2) -factor_key(framed$terms, framed$data) + # --------------------------------------------------------------------------- + # Interaction between two factors -# --------------------------------------------------------------------------- -# Nested effects (gear nested within cyl) + framed <- model_frame(bill_length_mm ~ species * island, penguins) + factor_key(framed$terms, framed$data) -mtcars2 <- mtcars -mtcars2$cyl_fct <- factor(mtcars2$cyl) -mtcars2$gear_fct <- factor(mtcars2$gear) -framed <- model_frame(mpg ~ cyl_fct / gear_fct, mtcars2) -# This expands to: mpg ~ cyl_fct + cyl_fct:gear_fct -factor_key(framed$terms, framed$data) + # --------------------------------------------------------------------------- + # Nested effects (Job nested within Home) -# --------------------------------------------------------------------------- -# No factors returns empty tibble + framed <- model_frame(Income ~ Home / Job, credit_data) + # This expands to: Income ~ Home + Home:Job + factor_key(framed$terms, framed$data) -framed <- model_frame(Sepal.Width ~ Sepal.Length + Petal.Width, iris) -factor_key(framed$terms, framed$data) + # --------------------------------------------------------------------------- + # No factors returns empty tibble -# --------------------------------------------------------------------------- -# Custom contrasts + data(concrete) + framed <- model_frame(compressive_strength ~ cement + water, concrete) + factor_key(framed$terms, framed$data) + + # --------------------------------------------------------------------------- + # Custom contrasts + + penguins2 <- penguins + species_sum <- penguins2$species + contrasts(species_sum) <- contr.sum(3) + penguins2$species <- species_sum + + framed <- model_frame(bill_length_mm ~ species, penguins2) + factor_key(framed$terms, framed$data) + + # --------------------------------------------------------------------------- + # Using with blueprints from mold() -species_sum <- iris$Species -contrasts(species_sum) <- contr.sum(3) -iris2 <- iris -iris2$Species <- species_sum + # Formula blueprint + molded <- mold(bill_length_mm ~ species + island, penguins) + factor_key(molded$blueprint, penguins) -framed <- model_frame(Sepal.Width ~ Species, iris2) + # XY blueprint (returns empty tibble since no terms/factors) + bp_xy <- default_xy_blueprint() + molded_xy <- mold(penguins[c("species", "island")], + penguins["bill_length_mm"], + blueprint = bp_xy) + factor_key(molded_xy$blueprint) +} + +# --------------------------------------------------------------------------- +# Ordered factor with polynomial contrasts + +data(mtcars) +mtcars2 <- mtcars +mtcars2$gear_ord <- ordered(mtcars2$gear) +framed <- model_frame(mpg ~ gear_ord, mtcars2) factor_key(framed$terms, framed$data) } diff --git a/tests/testthat/_snaps/factor-key.md b/tests/testthat/_snaps/factor-key.md index f27b505b..a6fe0210 100644 --- a/tests/testthat/_snaps/factor-key.md +++ b/tests/testthat/_snaps/factor-key.md @@ -3,8 +3,8 @@ Code factor_key("not_terms", framed$data) Condition - Error in `factor_key()`: - ! `terms` must be a , not the string "not_terms". + Error in `UseMethod()`: + ! no applicable method for 'factor_key' applied to an object of class "character" --- @@ -24,3 +24,13 @@ x Problematic argument: * extra = "arg" +# factor_key errors appropriately for recipe_blueprint + + Code + factor_key(blueprint) + Condition + Error in `factor_key()`: + ! factor_key() is not yet implemented for recipe blueprints. + i Recipes handle factor encoding during the prep step. + i Consider using a formula blueprint if you need factor mappings. + diff --git a/tests/testthat/test-factor-key.R b/tests/testthat/test-factor-key.R index ff233e41..91c2bb00 100644 --- a/tests/testthat/test-factor-key.R +++ b/tests/testthat/test-factor-key.R @@ -1,32 +1,36 @@ test_that("factor_key works with simple factor", { + skip_if_not_installed("modeldata") + library(modeldata) + # Single factor with default treatment contrasts - df <- data.frame( - y = 1:9, - f1 = factor(rep(c("a", "b", "c"), 3)) - ) - framed <- model_frame(y ~ f1, df) + data(penguins) + penguins_clean <- na.omit(penguins[c("bill_length_mm", "species")]) + framed <- model_frame(bill_length_mm ~ species, penguins_clean) result <- factor_key(framed$terms, framed$data) expect_s3_class(result, "tbl_df") expect_identical(colnames(result), c("source", "derived")) expect_equal(nrow(result), 2) # 3 levels - 1 reference = 2 columns - expect_true(all(result$source == "f1")) - expect_equal(sort(result$derived), c("f1b", "f1c")) + expect_true(all(result$source == "species")) + # Adelie is reference, so Chinstrap and Gentoo + expect_true(all(grepl("species", result$derived))) }) test_that("factor_key works with multiple factors", { - df <- data.frame( - y = 1:12, - f1 = factor(rep(c("a", "b"), 6)), - f2 = factor(rep(c("x", "y", "z"), 4)) - ) - framed <- model_frame(y ~ f1 + f2, df) + skip_if_not_installed("modeldata") + library(modeldata) + + data(credit_data) + # Use a subset for cleaner testing + credit_subset <- credit_data[1:100, ] + framed <- model_frame(Income ~ Home + Job, credit_subset) result <- factor_key(framed$terms, framed$data) expect_s3_class(result, "tbl_df") - expect_equal(nrow(result), 3) # 1 from f1 (2-1) + 2 from f2 (3-1) - expect_equal(sum(result$source == "f1"), 1) - expect_equal(sum(result$source == "f2"), 2) + # Home has 6 levels (5 columns), Job has 4 levels (3 columns) + expect_true(nrow(result) > 0) + expect_true("Home" %in% result$source) + expect_true("Job" %in% result$source) }) test_that("factor_key works with ordered factors", { @@ -59,21 +63,19 @@ test_that("factor_key returns empty tibble when no factors", { }) test_that("factor_key works with two-way interactions", { - df <- data.frame( - y = 1:12, - f1 = factor(rep(c("a", "b"), 6)), - f2 = factor(rep(c("x", "y", "z"), 4)) - ) - framed <- model_frame(y ~ f1 * f2, df) + skip_if_not_installed("modeldata") + library(modeldata) + + data(penguins) + penguins_clean <- na.omit(penguins[c("bill_length_mm", "species", "island")]) + framed <- model_frame(bill_length_mm ~ species * island, penguins_clean) result <- factor_key(framed$terms, framed$data) # Should have main effects and interactions expect_s3_class(result, "tbl_df") - # Main effects: 1 from f1, 2 from f2 - # Interactions: 1*2 = 2 columns, each mapped to both factors - # Total rows: 1 + 2 + 2*2 = 7 - expect_equal(nrow(result), 7) + # Main effects and interaction effects + expect_true(nrow(result) > 4) # At least main effects # Check interaction columns are mapped to both factors interaction_cols <- result$derived[grepl(":", result$derived)] @@ -82,8 +84,7 @@ test_that("factor_key works with two-way interactions", { for (int_col in unique(interaction_cols)) { sources <- result$source[result$derived == int_col] expect_equal(length(sources), 2) - expect_true("f1" %in% sources) - expect_true("f2" %in% sources) + expect_true(all(sources %in% c("species", "island"))) } }) @@ -396,3 +397,150 @@ test_that("factor_key works with formula containing dots", { # But not x (numeric) expect_false("x" %in% result$source) }) + +# ------------------------------------------------------------------------------ +# Blueprint methods tests + +test_that("factor_key works with default_formula_blueprint", { + # Create blueprint using mold + df <- data.frame( + y = 1:9, + f1 = factor(rep(c("a", "b", "c"), 3)) + ) + molded <- mold(y ~ f1, df) + blueprint <- molded$blueprint + + # Call factor_key with blueprint and data + result <- factor_key(blueprint, df) + + expect_s3_class(result, "tbl_df") + expect_identical(colnames(result), c("source", "derived")) + # Note: mold with default_formula_blueprint creates factors differently + # It may include all levels depending on indicators setting + expect_true(nrow(result) >= 2) + expect_true(all(result$source == "f1")) + expect_true(all(grepl("f1", result$derived))) +}) + +test_that("factor_key works with formula_blueprint with interactions", { + df <- data.frame( + y = 1:12, + f1 = factor(rep(c("a", "b"), 6)), + f2 = factor(rep(c("x", "y", "z"), 4)) + ) + molded <- mold(y ~ f1 * f2, df) + blueprint <- molded$blueprint + + result <- factor_key(blueprint, df) + + expect_s3_class(result, "tbl_df") + # Should have mappings for main effects and interactions + expect_true(nrow(result) > 3) # More than just main effects + + # Check interaction columns are mapped to both factors + interaction_cols <- result$derived[grepl(":", result$derived)] + expect_true(length(interaction_cols) > 0) +}) + +test_that("factor_key works with formula_blueprint with nested effects", { + df <- data.frame( + y = rnorm(24), + A = factor(rep(c("a1", "a2"), each = 12)), + B = factor(rep(c("b1", "b2", "b3"), 8)) + ) + + # A/B expands to A + A:B + molded <- mold(y ~ A / B, df) + blueprint <- molded$blueprint + + result <- factor_key(blueprint, df) + + expect_s3_class(result, "tbl_df") + # Should have mappings for A and A:B interaction terms + expect_true(nrow(result) >= 5) # At least some mappings + expect_true("A" %in% result$source) + expect_true("B" %in% result$source) +}) + +test_that("factor_key returns empty tibble for xy_blueprint", { + df <- data.frame( + y = 1:10, + f1 = factor(rep(c("a", "b"), 5)), + x = rnorm(10) + ) + + # Create XY blueprint + bp <- default_xy_blueprint() + predictors <- df[, c("f1", "x")] + outcomes <- df["y"] + molded <- mold(predictors, outcomes, blueprint = bp) + blueprint <- molded$blueprint + + # XY blueprints don't have terms, so should return empty tibble + result <- factor_key(blueprint) + + expect_s3_class(result, "tbl_df") + expect_identical(colnames(result), c("source", "derived")) + expect_equal(nrow(result), 0) +}) + +test_that("factor_key errors appropriately for recipe_blueprint", { + skip_if_not_installed("recipes") + + library(recipes) + df <- data.frame( + y = 1:10, + f1 = factor(rep(c("a", "b"), 5)) + ) + + # Create recipe blueprint + rec <- recipe(y ~ f1, data = df) + bp <- default_recipe_blueprint() + molded <- mold(rec, df, blueprint = bp) + blueprint <- molded$blueprint + + expect_snapshot(error = TRUE, { + factor_key(blueprint) + }) +}) + +test_that("factor_key requires data argument for formula blueprint", { + df <- data.frame( + y = 1:9, + f1 = factor(rep(c("a", "b", "c"), 3)) + ) + molded <- mold(y ~ f1, df) + blueprint <- molded$blueprint + + # Should error if data not provided + expect_error(factor_key(blueprint), class = "rlang_error") +}) + +test_that("factor_key works with different blueprint indicators", { + df <- data.frame( + y = 1:9, + f1 = factor(rep(c("a", "b", "c"), 3)) + ) + + # Test with indicators = "one_hot" + bp_onehot <- default_formula_blueprint(indicators = "one_hot") + molded <- mold(y ~ f1, df, blueprint = bp_onehot) + blueprint <- molded$blueprint + + result <- factor_key(blueprint, df) + + expect_s3_class(result, "tbl_df") + expect_true(nrow(result) > 0) + expect_true(all(result$source == "f1")) + + # Test with indicators = "none" + bp_none <- default_formula_blueprint(indicators = "none") + molded <- mold(y ~ f1, df, blueprint = bp_none) + blueprint <- molded$blueprint + + result <- factor_key(blueprint, df) + + expect_s3_class(result, "tbl_df") + # With indicators = "none", factors stay as factors + expect_true(nrow(result) >= 0) +}) From 21dd0b5030826a957c0725720124c4b49cf3dba2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E2=80=98topepo=E2=80=99?= Date: Mon, 8 Jun 2026 11:20:14 -0400 Subject: [PATCH 3/4] update docs --- DESCRIPTION | 2 +- R/factor-key.R | 67 ++++++++++++++++++------- man/factor_key.Rd | 19 +++---- man/get_levels.Rd | 2 +- man/hardhat-package.Rd | 1 + man/impute_quantiles.Rd | 2 +- man/model_offset.Rd | 4 +- man/validate_column_names.Rd | 16 +++--- man/validate_no_formula_duplication.Rd | 16 +++--- man/validate_outcomes_are_binary.Rd | 16 +++--- man/validate_outcomes_are_factors.Rd | 16 +++--- man/validate_outcomes_are_numeric.Rd | 16 +++--- man/validate_outcomes_are_univariate.Rd | 16 +++--- man/validate_prediction_size.Rd | 16 +++--- man/validate_predictors_are_numeric.Rd | 16 +++--- man/weighted_table.Rd | 2 +- 16 files changed, 127 insertions(+), 100 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 37d3449b..0b2c5e37 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -50,4 +50,4 @@ Config/usethis/last-upkeep: 2025-04-23 Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.3 +Config/roxygen2/version: 8.0.0 diff --git a/R/factor-key.R b/R/factor-key.R index 6eb2881a..10bdb8ce 100644 --- a/R/factor-key.R +++ b/R/factor-key.R @@ -45,41 +45,38 @@ #' # --------------------------------------------------------------------------- #' # Simple factor with treatment contrasts (default) #' -#' data(penguins) -#' framed <- model_frame(bill_length_mm ~ species, penguins) +#' framed <- model_frame(bill_length_mm ~ species, modeldata::penguins) #' factor_key(framed$terms, framed$data) #' #' # --------------------------------------------------------------------------- #' # Multiple factors #' -#' data(credit_data) -#' framed <- model_frame(Income ~ Home + Job, credit_data) +#' framed <- model_frame(Income ~ Home + Job, modeldata::credit_data) #' factor_key(framed$terms, framed$data) #' #' # --------------------------------------------------------------------------- #' # Interaction between two factors #' -#' framed <- model_frame(bill_length_mm ~ species * island, penguins) +#' framed <- model_frame(bill_length_mm ~ species * island, modeldata::penguins) #' factor_key(framed$terms, framed$data) #' #' # --------------------------------------------------------------------------- #' # Nested effects (Job nested within Home) #' -#' framed <- model_frame(Income ~ Home / Job, credit_data) +#' framed <- model_frame(Income ~ Home / Job, modeldata::credit_data) #' # This expands to: Income ~ Home + Home:Job #' factor_key(framed$terms, framed$data) #' #' # --------------------------------------------------------------------------- #' # No factors returns empty tibble #' -#' data(concrete) -#' framed <- model_frame(compressive_strength ~ cement + water, concrete) +#' framed <- model_frame(compressive_strength ~ cement + water, modeldata::concrete) #' factor_key(framed$terms, framed$data) #' #' # --------------------------------------------------------------------------- #' # Custom contrasts #' -#' penguins2 <- penguins +#' penguins2 <- modeldata::penguins #' species_sum <- penguins2$species #' contrasts(species_sum) <- contr.sum(3) #' penguins2$species <- species_sum @@ -96,8 +93,8 @@ #' #' # XY blueprint (returns empty tibble since no terms/factors) #' bp_xy <- default_xy_blueprint() -#' molded_xy <- mold(penguins[c("species", "island")], -#' penguins["bill_length_mm"], +#' molded_xy <- mold(modeldata::penguins[c("species", "island")], +#' modeldata::penguins["bill_length_mm"], #' blueprint = bp_xy) #' factor_key(molded_xy$blueprint) #' } @@ -150,7 +147,9 @@ factor_key.terms <- function(x, data, ..., call = current_env()) { # Identify factor and ordered variables # Note: "ordered" is a subclass of "factor" but stored separately in dataClasses - factor_vars <- names(data_classes)[data_classes %in% c("factor", "ordered", "character")] + factor_vars <- names(data_classes)[ + data_classes %in% c("factor", "ordered", "character") + ] # If no factors, return empty tibble with correct structure if (length(factor_vars) == 0) { @@ -166,7 +165,12 @@ factor_key.terms <- function(x, data, ..., call = current_env()) { }, error = function(e) { # Check if it's the single-level factor error - if (grepl("contrasts can be applied only to factors with 2 or more levels", e$message)) { + if ( + grepl( + "contrasts can be applied only to factors with 2 or more levels", + e$message + ) + ) { # Return NULL to indicate no model matrix could be created return(NULL) } @@ -211,7 +215,9 @@ factor_key.terms <- function(x, data, ..., call = current_env()) { term_label <- term_labels[term_index] # Find which variables contribute to this term - contributing_vars <- rownames(factors_matrix)[factors_matrix[, term_index] > 0] + contributing_vars <- rownames(factors_matrix)[ + factors_matrix[, term_index] > 0 + ] # Filter to only factor variables factor_contributors <- intersect(contributing_vars, factor_vars) @@ -257,14 +263,22 @@ get_first_class <- function(var, data) { #' #' @rdname factor_key #' @export -factor_key.default_formula_blueprint <- function(x, data, ..., call = current_env()) { +factor_key.default_formula_blueprint <- function( + x, + data, + ..., + call = current_env() +) { check_dots_empty0(...) # Extract the predictors terms from the blueprint terms_obj <- x$terms$predictors if (is.null(terms_obj)) { - cli::cli_abort("Blueprint does not contain terms for predictors.", call = call) + cli::cli_abort( + "Blueprint does not contain terms for predictors.", + call = call + ) } # Call the terms method @@ -290,7 +304,12 @@ factor_key.formula_blueprint <- function(x, data, ..., call = current_env()) { #' @rdname factor_key #' @export -factor_key.default_recipe_blueprint <- function(x, data = NULL, ..., call = current_env()) { +factor_key.default_recipe_blueprint <- function( + x, + data = NULL, + ..., + call = current_env() +) { check_dots_empty0(...) # Recipes handle factors differently - they may encode them during prep @@ -307,14 +326,24 @@ factor_key.default_recipe_blueprint <- function(x, data = NULL, ..., call = curr #' @rdname factor_key #' @export -factor_key.recipe_blueprint <- function(x, data = NULL, ..., call = current_env()) { +factor_key.recipe_blueprint <- function( + x, + data = NULL, + ..., + call = current_env() +) { # Fallback for non-default recipe blueprints factor_key.default_recipe_blueprint(x, data, ..., call = call) } #' @rdname factor_key #' @export -factor_key.default_xy_blueprint <- function(x, data = NULL, ..., call = current_env()) { +factor_key.default_xy_blueprint <- function( + x, + data = NULL, + ..., + call = current_env() +) { check_dots_empty0(...) # XY blueprints don't use terms or formulas, so there's no factor encoding to map diff --git a/man/factor_key.Rd b/man/factor_key.Rd index c8a98f5f..84d0a2eb 100644 --- a/man/factor_key.Rd +++ b/man/factor_key.Rd @@ -80,41 +80,38 @@ if (rlang::is_installed("modeldata")) { # --------------------------------------------------------------------------- # Simple factor with treatment contrasts (default) - data(penguins) - framed <- model_frame(bill_length_mm ~ species, penguins) + framed <- model_frame(bill_length_mm ~ species, modeldata::penguins) factor_key(framed$terms, framed$data) # --------------------------------------------------------------------------- # Multiple factors - data(credit_data) - framed <- model_frame(Income ~ Home + Job, credit_data) + framed <- model_frame(Income ~ Home + Job, modeldata::credit_data) factor_key(framed$terms, framed$data) # --------------------------------------------------------------------------- # Interaction between two factors - framed <- model_frame(bill_length_mm ~ species * island, penguins) + framed <- model_frame(bill_length_mm ~ species * island, modeldata::penguins) factor_key(framed$terms, framed$data) # --------------------------------------------------------------------------- # Nested effects (Job nested within Home) - framed <- model_frame(Income ~ Home / Job, credit_data) + framed <- model_frame(Income ~ Home / Job, modeldata::credit_data) # This expands to: Income ~ Home + Home:Job factor_key(framed$terms, framed$data) # --------------------------------------------------------------------------- # No factors returns empty tibble - data(concrete) - framed <- model_frame(compressive_strength ~ cement + water, concrete) + framed <- model_frame(compressive_strength ~ cement + water, modeldata::concrete) factor_key(framed$terms, framed$data) # --------------------------------------------------------------------------- # Custom contrasts - penguins2 <- penguins + penguins2 <- modeldata::penguins species_sum <- penguins2$species contrasts(species_sum) <- contr.sum(3) penguins2$species <- species_sum @@ -131,8 +128,8 @@ if (rlang::is_installed("modeldata")) { # XY blueprint (returns empty tibble since no terms/factors) bp_xy <- default_xy_blueprint() - molded_xy <- mold(penguins[c("species", "island")], - penguins["bill_length_mm"], + molded_xy <- mold(modeldata::penguins[c("species", "island")], + modeldata::penguins["bill_length_mm"], blueprint = bp_xy) factor_key(molded_xy$blueprint) } diff --git a/man/get_levels.Rd b/man/get_levels.Rd index 3a42d689..c8442f32 100644 --- a/man/get_levels.Rd +++ b/man/get_levels.Rd @@ -50,5 +50,5 @@ get_levels(mtcars) get_outcome_levels(y = factor(letters[1:5])) } \seealso{ -\code{\link[stats:checkMFClasses]{stats::.getXlevels()}} +\code{\link[stats:.getXlevels]{stats::.getXlevels()}} } diff --git a/man/hardhat-package.Rd b/man/hardhat-package.Rd index f4c97b40..3f893e7b 100644 --- a/man/hardhat-package.Rd +++ b/man/hardhat-package.Rd @@ -24,6 +24,7 @@ Useful links: Authors: \itemize{ + \item Hannah Frick \email{hannah@posit.co} (\href{https://orcid.org/0000-0002-6049-5258}{ORCID}) \item Davis Vaughan \email{davis@posit.co} \item Max Kuhn \email{max@posit.co} } diff --git a/man/impute_quantiles.Rd b/man/impute_quantiles.Rd index ce7772b0..75b576a8 100644 --- a/man/impute_quantiles.Rd +++ b/man/impute_quantiles.Rd @@ -56,7 +56,7 @@ First, by default (\code{middle = "cubic"}), missing \emph{internal} quantile le interpolated using a cubic spline fit to the observed values + quantile levels with \link[stats:splinefun]{stats::splinefun}. Second, if cubic interpolation fails (or if -\code{middle = "linear"}), linear interpolation is used via \link[stats:approxfun]{stats::approx}. +\code{middle = "linear"}), linear interpolation is used via \link[stats:approx]{stats::approx}. Finally, missing \emph{external} quantile levels (those outside the range of \code{quantile_levels}) are extrapolated. This is done using a linear fit on the logistic scale to the two closest tail values. diff --git a/man/model_offset.Rd b/man/model_offset.Rd index d7f6922c..badc9a6a 100644 --- a/man/model_offset.Rd +++ b/man/model_offset.Rd @@ -21,14 +21,14 @@ A numeric vector representing the offset. } \description{ \code{model_offset()} extracts a numeric offset from a model frame. It is -inspired by \code{\link[stats:model.extract]{stats::model.offset()}}, but has nicer error messages and +inspired by \code{\link[stats:model.offset]{stats::model.offset()}}, but has nicer error messages and is slightly stricter. } \details{ If a column that has been tagged as an offset is not numeric, a nice error message is thrown telling you exactly which column was problematic. -\code{\link[stats:model.extract]{stats::model.offset()}} also allows for a column named \code{"(offset)"} to be +\code{\link[stats:model.offset]{stats::model.offset()}} also allows for a column named \code{"(offset)"} to be considered an offset along with any others that have been tagged by \code{\link[stats:offset]{stats::offset()}}. However, \code{\link[stats:model.matrix]{stats::model.matrix()}} does not recognize these columns as offsets (so it doesn't remove them as it should). Because diff --git a/man/validate_column_names.Rd b/man/validate_column_names.Rd index 43e889d7..2823648e 100644 --- a/man/validate_column_names.Rd +++ b/man/validate_column_names.Rd @@ -109,13 +109,13 @@ test$.outcome <- test$Species forge(test, processed$blueprint, outcomes = TRUE) } \seealso{ -Other validation functions: -\code{\link{validate_no_formula_duplication}()}, -\code{\link{validate_outcomes_are_binary}()}, -\code{\link{validate_outcomes_are_factors}()}, -\code{\link{validate_outcomes_are_numeric}()}, -\code{\link{validate_outcomes_are_univariate}()}, -\code{\link{validate_prediction_size}()}, -\code{\link{validate_predictors_are_numeric}()} +Other validation functions: +\code{\link[=validate_no_formula_duplication]{validate_no_formula_duplication()}}, +\code{\link[=validate_outcomes_are_binary]{validate_outcomes_are_binary()}}, +\code{\link[=validate_outcomes_are_factors]{validate_outcomes_are_factors()}}, +\code{\link[=validate_outcomes_are_numeric]{validate_outcomes_are_numeric()}}, +\code{\link[=validate_outcomes_are_univariate]{validate_outcomes_are_univariate()}}, +\code{\link[=validate_prediction_size]{validate_prediction_size()}}, +\code{\link[=validate_predictors_are_numeric]{validate_predictors_are_numeric()}} } \concept{validation functions} diff --git a/man/validate_no_formula_duplication.Rd b/man/validate_no_formula_duplication.Rd index 589421f9..12d38710 100644 --- a/man/validate_no_formula_duplication.Rd +++ b/man/validate_no_formula_duplication.Rd @@ -70,13 +70,13 @@ check_no_formula_duplication(y ~ log(y), original = TRUE) try(validate_no_formula_duplication(log(y) ~ log(y))) } \seealso{ -Other validation functions: -\code{\link{validate_column_names}()}, -\code{\link{validate_outcomes_are_binary}()}, -\code{\link{validate_outcomes_are_factors}()}, -\code{\link{validate_outcomes_are_numeric}()}, -\code{\link{validate_outcomes_are_univariate}()}, -\code{\link{validate_prediction_size}()}, -\code{\link{validate_predictors_are_numeric}()} +Other validation functions: +\code{\link[=validate_column_names]{validate_column_names()}}, +\code{\link[=validate_outcomes_are_binary]{validate_outcomes_are_binary()}}, +\code{\link[=validate_outcomes_are_factors]{validate_outcomes_are_factors()}}, +\code{\link[=validate_outcomes_are_numeric]{validate_outcomes_are_numeric()}}, +\code{\link[=validate_outcomes_are_univariate]{validate_outcomes_are_univariate()}}, +\code{\link[=validate_prediction_size]{validate_prediction_size()}}, +\code{\link[=validate_predictors_are_numeric]{validate_predictors_are_numeric()}} } \concept{validation functions} diff --git a/man/validate_outcomes_are_binary.Rd b/man/validate_outcomes_are_binary.Rd index afca9d14..b3f9ffde 100644 --- a/man/validate_outcomes_are_binary.Rd +++ b/man/validate_outcomes_are_binary.Rd @@ -68,13 +68,13 @@ check_outcomes_are_binary(data.frame(x = factor("A"))) check_outcomes_are_binary(data.frame(x = factor(c("A", "B")))) } \seealso{ -Other validation functions: -\code{\link{validate_column_names}()}, -\code{\link{validate_no_formula_duplication}()}, -\code{\link{validate_outcomes_are_factors}()}, -\code{\link{validate_outcomes_are_numeric}()}, -\code{\link{validate_outcomes_are_univariate}()}, -\code{\link{validate_prediction_size}()}, -\code{\link{validate_predictors_are_numeric}()} +Other validation functions: +\code{\link[=validate_column_names]{validate_column_names()}}, +\code{\link[=validate_no_formula_duplication]{validate_no_formula_duplication()}}, +\code{\link[=validate_outcomes_are_factors]{validate_outcomes_are_factors()}}, +\code{\link[=validate_outcomes_are_numeric]{validate_outcomes_are_numeric()}}, +\code{\link[=validate_outcomes_are_univariate]{validate_outcomes_are_univariate()}}, +\code{\link[=validate_prediction_size]{validate_prediction_size()}}, +\code{\link[=validate_predictors_are_numeric]{validate_predictors_are_numeric()}} } \concept{validation functions} diff --git a/man/validate_outcomes_are_factors.Rd b/man/validate_outcomes_are_factors.Rd index 44c60fc7..b157a6ca 100644 --- a/man/validate_outcomes_are_factors.Rd +++ b/man/validate_outcomes_are_factors.Rd @@ -64,13 +64,13 @@ check_outcomes_are_factors(data.frame(x = 1)) check_outcomes_are_factors(data.frame(x = factor(c("A", "B")))) } \seealso{ -Other validation functions: -\code{\link{validate_column_names}()}, -\code{\link{validate_no_formula_duplication}()}, -\code{\link{validate_outcomes_are_binary}()}, -\code{\link{validate_outcomes_are_numeric}()}, -\code{\link{validate_outcomes_are_univariate}()}, -\code{\link{validate_prediction_size}()}, -\code{\link{validate_predictors_are_numeric}()} +Other validation functions: +\code{\link[=validate_column_names]{validate_column_names()}}, +\code{\link[=validate_no_formula_duplication]{validate_no_formula_duplication()}}, +\code{\link[=validate_outcomes_are_binary]{validate_outcomes_are_binary()}}, +\code{\link[=validate_outcomes_are_numeric]{validate_outcomes_are_numeric()}}, +\code{\link[=validate_outcomes_are_univariate]{validate_outcomes_are_univariate()}}, +\code{\link[=validate_prediction_size]{validate_prediction_size()}}, +\code{\link[=validate_predictors_are_numeric]{validate_predictors_are_numeric()}} } \concept{validation functions} diff --git a/man/validate_outcomes_are_numeric.Rd b/man/validate_outcomes_are_numeric.Rd index 9a0d8645..57e3daa2 100644 --- a/man/validate_outcomes_are_numeric.Rd +++ b/man/validate_outcomes_are_numeric.Rd @@ -67,13 +67,13 @@ check_outcomes_are_numeric(iris) try(validate_outcomes_are_numeric(iris)) } \seealso{ -Other validation functions: -\code{\link{validate_column_names}()}, -\code{\link{validate_no_formula_duplication}()}, -\code{\link{validate_outcomes_are_binary}()}, -\code{\link{validate_outcomes_are_factors}()}, -\code{\link{validate_outcomes_are_univariate}()}, -\code{\link{validate_prediction_size}()}, -\code{\link{validate_predictors_are_numeric}()} +Other validation functions: +\code{\link[=validate_column_names]{validate_column_names()}}, +\code{\link[=validate_no_formula_duplication]{validate_no_formula_duplication()}}, +\code{\link[=validate_outcomes_are_binary]{validate_outcomes_are_binary()}}, +\code{\link[=validate_outcomes_are_factors]{validate_outcomes_are_factors()}}, +\code{\link[=validate_outcomes_are_univariate]{validate_outcomes_are_univariate()}}, +\code{\link[=validate_prediction_size]{validate_prediction_size()}}, +\code{\link[=validate_predictors_are_numeric]{validate_predictors_are_numeric()}} } \concept{validation functions} diff --git a/man/validate_outcomes_are_univariate.Rd b/man/validate_outcomes_are_univariate.Rd index a1bc5798..d7a1107f 100644 --- a/man/validate_outcomes_are_univariate.Rd +++ b/man/validate_outcomes_are_univariate.Rd @@ -58,13 +58,13 @@ validate_outcomes_are_univariate(data.frame(x = 1)) try(validate_outcomes_are_univariate(mtcars)) } \seealso{ -Other validation functions: -\code{\link{validate_column_names}()}, -\code{\link{validate_no_formula_duplication}()}, -\code{\link{validate_outcomes_are_binary}()}, -\code{\link{validate_outcomes_are_factors}()}, -\code{\link{validate_outcomes_are_numeric}()}, -\code{\link{validate_prediction_size}()}, -\code{\link{validate_predictors_are_numeric}()} +Other validation functions: +\code{\link[=validate_column_names]{validate_column_names()}}, +\code{\link[=validate_no_formula_duplication]{validate_no_formula_duplication()}}, +\code{\link[=validate_outcomes_are_binary]{validate_outcomes_are_binary()}}, +\code{\link[=validate_outcomes_are_factors]{validate_outcomes_are_factors()}}, +\code{\link[=validate_outcomes_are_numeric]{validate_outcomes_are_numeric()}}, +\code{\link[=validate_prediction_size]{validate_prediction_size()}}, +\code{\link[=validate_predictors_are_numeric]{validate_predictors_are_numeric()}} } \concept{validation functions} diff --git a/man/validate_prediction_size.Rd b/man/validate_prediction_size.Rd index f78b77d8..d97f54e9 100644 --- a/man/validate_prediction_size.Rd +++ b/man/validate_prediction_size.Rd @@ -87,13 +87,13 @@ check_prediction_size(pred, new_data) try(validate_prediction_size(spruce_numeric(1:4), new_data)) } \seealso{ -Other validation functions: -\code{\link{validate_column_names}()}, -\code{\link{validate_no_formula_duplication}()}, -\code{\link{validate_outcomes_are_binary}()}, -\code{\link{validate_outcomes_are_factors}()}, -\code{\link{validate_outcomes_are_numeric}()}, -\code{\link{validate_outcomes_are_univariate}()}, -\code{\link{validate_predictors_are_numeric}()} +Other validation functions: +\code{\link[=validate_column_names]{validate_column_names()}}, +\code{\link[=validate_no_formula_duplication]{validate_no_formula_duplication()}}, +\code{\link[=validate_outcomes_are_binary]{validate_outcomes_are_binary()}}, +\code{\link[=validate_outcomes_are_factors]{validate_outcomes_are_factors()}}, +\code{\link[=validate_outcomes_are_numeric]{validate_outcomes_are_numeric()}}, +\code{\link[=validate_outcomes_are_univariate]{validate_outcomes_are_univariate()}}, +\code{\link[=validate_predictors_are_numeric]{validate_predictors_are_numeric()}} } \concept{validation functions} diff --git a/man/validate_predictors_are_numeric.Rd b/man/validate_predictors_are_numeric.Rd index 791542c2..e7bd5bd2 100644 --- a/man/validate_predictors_are_numeric.Rd +++ b/man/validate_predictors_are_numeric.Rd @@ -67,13 +67,13 @@ check_predictors_are_numeric(iris) try(validate_predictors_are_numeric(iris)) } \seealso{ -Other validation functions: -\code{\link{validate_column_names}()}, -\code{\link{validate_no_formula_duplication}()}, -\code{\link{validate_outcomes_are_binary}()}, -\code{\link{validate_outcomes_are_factors}()}, -\code{\link{validate_outcomes_are_numeric}()}, -\code{\link{validate_outcomes_are_univariate}()}, -\code{\link{validate_prediction_size}()} +Other validation functions: +\code{\link[=validate_column_names]{validate_column_names()}}, +\code{\link[=validate_no_formula_duplication]{validate_no_formula_duplication()}}, +\code{\link[=validate_outcomes_are_binary]{validate_outcomes_are_binary()}}, +\code{\link[=validate_outcomes_are_factors]{validate_outcomes_are_factors()}}, +\code{\link[=validate_outcomes_are_numeric]{validate_outcomes_are_numeric()}}, +\code{\link[=validate_outcomes_are_univariate]{validate_outcomes_are_univariate()}}, +\code{\link[=validate_prediction_size]{validate_prediction_size()}} } \concept{validation functions} diff --git a/man/weighted_table.Rd b/man/weighted_table.Rd index e28fda4c..67228c8f 100644 --- a/man/weighted_table.Rd +++ b/man/weighted_table.Rd @@ -33,7 +33,7 @@ properties: \itemize{ \item Missing values found in the factors are never included in the table unless there is an explicit \code{NA} factor level. If needed, this can be added to a -factor with \code{\link[base:factor]{base::addNA()}} or \code{forcats::fct_expand(x, NA)}. +factor with \code{\link[base:addNA]{base::addNA()}} or \code{forcats::fct_expand(x, NA)}. \item Levels found in the factors that aren't actually used in the underlying data are included in the table with a value of \code{0}. If needed, you can drop unused factor levels by re-running your factor through \code{\link[=factor]{factor()}}, From 05f608a0d34e84d4801ad888ea93533c64f4e02f Mon Sep 17 00:00:00 2001 From: Max Kuhn Date: Mon, 8 Jun 2026 11:26:48 -0400 Subject: [PATCH 4/4] Update tests/testthat/test-factor-key.R Co-authored-by: github-actions[bot] <41898282+github-actions[bot]@users.noreply.github.com> --- tests/testthat/test-factor-key.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-factor-key.R b/tests/testthat/test-factor-key.R index 91c2bb00..2b1b32b4 100644 --- a/tests/testthat/test-factor-key.R +++ b/tests/testthat/test-factor-key.R @@ -348,7 +348,9 @@ test_that("factor_key handles complex nested structures", { # Check we have mappings for all terms # Main effect A - main_a <- result[result$derived %in% result$derived[!grepl(":", result$derived)], ] + main_a <- result[ + result$derived %in% result$derived[!grepl(":", result$derived)], + ] expect_true(nrow(main_a) > 0) # A:B interaction