From 4f97c1250ef68e8c696b15c7d4b7fe38c3a82437 Mon Sep 17 00:00:00 2001 From: thomaz Date: Wed, 15 Jul 2026 21:51:23 +0200 Subject: [PATCH 1/2] Refactored `weave()`, `stack()`. still need to integrate `weave_coverage()` and `select_path()` itself. Added tests for path-utils. --- R/AllClasses.R | 4 +- R/path-utils.R | 122 ++++++++++++++-------- R/stack.R | 32 +++--- R/weave-coverage.R | 5 +- R/weave.R | 41 +++----- tests/testthat/test-path-utils.R | 34 ++++++ tests/testthat/test-weave-formula-utils.R | 4 +- 7 files changed, 152 insertions(+), 90 deletions(-) create mode 100644 tests/testthat/test-path-utils.R diff --git a/R/AllClasses.R b/R/AllClasses.R index 34bee20..eb17682 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -54,7 +54,6 @@ LinkMap <- S7::new_class( if( !NCOL(metadata) ) { metadata <- x@metadata } x <- `class<-`(S7::S7_data(x), "data.frame") } - x <- `row.names<-.data.frame`(x, NULL) if(!NCOL(metadata)) { metadata <- data.frame(row.names = seq_len(NROW(x))) } else { @@ -67,8 +66,9 @@ LinkMap <- S7::new_class( x[] <- lapply(x, factor) i <- !duplicated(x) x <- x[i, , drop = FALSE] + x <- `row.names<-.data.frame`(x, NULL) metadata <- metadata[i, , drop = FALSE] - + metadata <- `row.names<-.data.frame`(metadata, NULL) S7::new_object(x, metadata = metadata) }, validator = function(self) { diff --git a/R/path-utils.R b/R/path-utils.R index 421b1ff..90bf982 100644 --- a/R/path-utils.R +++ b/R/path-utils.R @@ -1,42 +1,85 @@ +#' Check .path input +#' @returns a named list with three variables. See details. +#' @details +#' `info` - How long is the provided path? `minimal` or `detailed`. +#' `complex` - `Logical`. Are the variables `ordinary` or concatenated with "+" `complex`. +#' `class`- .path class. `character`, `list`, `formula` or `data.frame`. +#' +#' @noRd +#' .check_path <- function(.path) { # Initialize output with defaults - res <- c(info = "minimal", vars = "ordinary", class = "character") + res <- list(info = "minimal", complex = logical(1L), class = "character") + classes <- c("character", "formula", "data.frame", "list") #Some grace for select_path output if(is.list(.path) && length(.path) == 1L) {.path <- .path[[1L]] } - - # Defenses - stopifnot("'.path' requires at least two variables." = length(.path) >= 2L ) stopifnot( "'.path' must be a formula or a (list of) character vector(s)." = - inherits(.path, c("character", "formula", "list")) + inherits(.path, c("character", "formula", "data.frame", "list")) ) - if(inherits(.path, "formula")) { - # Formula case - res["class"] <- "formula" - # TODO - # FIXME - if(.path_function_is_detailed(.path)) { - res["info"] <- "detailed" - } - } else { - # Character case - if(is.list(.path)) { - stopifnot( - "'.path' list elements must all be character vectors." = - all(vapply(.path, is.character, FUN.VALUE = FALSE)) - ) - if( any(lengths(.path) >= 2L) ) { res["vars"] <- "complex" } + # Capture one class for switch statement + res[["class"]] <- .pc <- intersect(class(.path), classes) + # Defenses + stopifnot("'.path' requires at least two variables." = length(.path) >= 2L) - } - if(length(.path) >= 3L ) res["info"] <- "detailed" + switch (.pc, + formula = { + ff <- .cut_fm_by_tildes(.path) + res[["complex"]] <- any(grepl(" + ", ff, fixed = TRUE)) + if( length(ff) > 2L ) res["info"] <- "detailed" + }, + list =, + character = { + stopifnot( + "'.path' list elements must all be character vectors." = + all(vapply(.path, is.character, FUN.VALUE = FALSE)) + ) + res[["complex"]] <- any(lengths(.path) >= 2L) + if( length(.path) >= 3L ) res["info"] <- "detailed" + }, + data.frame = { + stopifnot( + "If class(.path) == 'data.frame' it must have two columns" = + NCOL(.path) == 2L + ) + if(NROW(.path) >= 2L) res["info"] <- "detailed" + } + ) - } return(res) } +.std_path_to_list <- function(x, .path, check) switch( + check[["class"]], + "character" = res <- as.list(.path), + "data.frame" = res <- .path_df_to_list(.path), + "formula" = res <- as.list(.cut_fm_by_tildes(.path)), + "list" = res <- .path +) + +.select_std_path <- function(x, std_path) { + terms <- unlist(std_path[c(1L, length(std_path))], FALSE, FALSE) + include <- unlist(std_path[-c(1, length(std_path))], FALSE, FALSE) + if(!length(include)) { include <- NULL } + full_path <- .select_path( x, terms, include ) +} + + +#' @param std_path Takes a std list form and splits it by " + " for stack(). +#' @returns a std list with split variables. +#' @noRd +#' +.parse_stack_std_path <- function(std_path) unlist( + lapply(std_path, strsplit, split = " + ", fixed = TRUE), FALSE, FALSE +) + + +.path_df_to_list <- function(x) as.list(c(x[[1L]], x[[2L]][NROW(x)])) + + .path_ordinary_to_full <- function(x, .path) { if(inherits(.path, "formula")) { - all_terms <- unlist(strsplit(rlang::as_label(.path), " ~ ", fixed = TRUE)) + all_terms <- .cut_fm_by_tildes(.path) } else { all_terms <- .path } @@ -47,12 +90,6 @@ return(full_path) } -.build_path <- function(x, .path, pc) { - if(pc["class"] == "factor") { - - } - if(pc["vars"] == "complex") .path_prep_complex(.path) -} #' Standardize terms #' @returns a length 2 character vector of y, x. @@ -70,25 +107,26 @@ } } -#' @returns BOOL -#' @noRd + #' @importFrom rlang as_label -#' -.path_function_is_detailed <- function(.path) { - # Returns TRUE if more than one "~" seen. - length(unlist(strsplit(rlang::as_label(.path), "~", fixed = TRUE))) > 2L -} +#' @noRd +#' @returns a character vector of length >= 2L. +.cut_fm_by_tildes <- function(x) unlist( + strsplit(rlang::as_label(x), " ~ ", fixed = TRUE) + ) + + #' @importFrom stats reformulate #' @noRd #' @returns a list of step-wise formulae. -.path_prep_complex <- function(.path) { - all_terms <- unlist(strsplit(rlang::as_label(.path), "~", fixed = TRUE)) +.path_prep_fm_detailed <- function(.path) { + all_terms <- .cut_fm_by_tildes(.path) lapply( seq_len(length(all_terms) -1L), function(i) stats::reformulate(all_terms[i+1L], all_terms[i]) - ) - } + ) +} #' Standardize terms diff --git a/R/stack.R b/R/stack.R index 1c0a88a..e976cfa 100644 --- a/R/stack.R +++ b/R/stack.R @@ -34,20 +34,13 @@ S7::method(stack, MultiFactor) <- function( x, .path, out.format = c("LinkMap", "matrix"), ... ) { out.format <- match.arg(out.format, c("LinkMap", "matrix")) - .p_check <- .check_path(.path) - stopifnot( - "stack does not support '.path' with multiple tildes " = - .p_check["info"] == "minimal" - ) - if( .p_check["class"] == "formula" ) { - terms <- .path_parse_formula(.path) - } else { - terms <- .path - } - stopifnot( - "At least one side of '.path' must include several variables." = - any( lengths(terms) != 1L) - ) + # Handle .path arg + path_check <- .check_path(.path) + .path_check_valid_stack(path_check) + path_list <- .std_path_to_list(x, .path, path_check) + + terms <- .parse_stack_std_path(path_list) + res <- .stack_terms(x, terms, out.format = "LinkMap") if(out.format == "matrix") { res <- `as.matrix.MultiFactor::LinkMap`(res) @@ -55,6 +48,17 @@ S7::method(stack, MultiFactor) <- function( return(res) } +.path_check_valid_stack <- function(path_check) { + stopifnot( + "stack does not support '.path' with multiple tildes " = + path_check[["info"]] == "minimal" + ) + stopifnot( + "At least one side of '.path' must include variables combined by '+'." = + path_check[["complex"]] + ) +} + .stack_terms <- function(x, terms, out.format) { res <- apply( expand.grid(terms), 1L, .weave_ordinary_terms_df, diff --git a/R/weave-coverage.R b/R/weave-coverage.R index c297342..fa31bc5 100644 --- a/R/weave-coverage.R +++ b/R/weave-coverage.R @@ -47,12 +47,13 @@ weave_coverage <- function( ) out.format <- match.arg(out.format, c("LinkMap", "matrix")) - .p_check <- .check_path(.path) + path_check <- .check_path(.path) - if(.p_check["vars"] == "complex") { + if(path_check[["complex"]]) { stop("weave_coverage() '.path' cannot contain '+'.\n", "Use stack() to prepare input.") } + full_path <- .path_ordinary_to_full(x, .path)[[1L]] stopifnot( diff --git a/R/weave.R b/R/weave.R index 4478d2f..b82a30c 100644 --- a/R/weave.R +++ b/R/weave.R @@ -32,13 +32,13 @@ S7::method(weave, MultiFactor) <- function( out.format <- match.arg(out.format, c("LinkMap", "matrix")) lv_list <- levels(x) - .p_check <- .check_path(.path) + path_check <- .check_path(.path) - if(.p_check["vars"] == "complex") { - stop("weave() '.path' cannot contain '+'. Use stack() to prepare input.") - } - full_path <- .path_ordinary_to_full(x, .path)[[1L]] - res <- .weave_full_path(x, full_path, out.format) + .path_check_valid_weave(path_check) + path_list <- .std_path_to_list(x, .path, path_check) + full_path <- .select_std_path(x, path_list)[[1L]] + # full_path <- .path_ordinary_to_full(x, .path)[[1L]] + res <- .weave_full_path(x, full_path, out.format) if( out.format == "LinkMap" ) { res <- LinkMap(res) @@ -47,6 +47,13 @@ S7::method(weave, MultiFactor) <- function( return(res) } +.path_check_valid_weave <- function(path_check) { + if(path_check[["complex"]]) { + stop("weave() '.path' cannot contain '+'. Use stack() to prepare input.") + } +} + + weave_along_path <- function(x, path, out.format = "LinkMap") { # tolerate single path result in list @@ -68,28 +75,6 @@ weave_along_path <- function(x, path, out.format = "LinkMap") { } -.weave_complex_formula <- function(x, .path, out.format) { - .path_list <- .path_prep_complex(.path) - res <- lapply( .path_list, weave, x = x, out.format = out.format ) -} - -.weave_complex_formula_lvs <- function(x, lv_list) { - new_lvs <- .build_levels_from_linkmap_list(x) - new_names <- names(new_lvs) - kept <- intersect(new_names, names(lv_list)) - new_lvs <- list(lv_list[kept], new_lvs) - lv_list <- lapply( - new_names, - function(lv) { - x <- lapply(new_lvs, `[[`, lv) - x <- Reduce(union, x, init = character()) - return( sort(x) ) - } - ) - names(lv_list) <- new_names - return(lv_list) -} - .weave_ordinary_terms <- function(x, terms, out.format) { lv_list <- levels(x) # Determine required ids in order, only keep relevant elements of link. diff --git a/tests/testthat/test-path-utils.R b/tests/testthat/test-path-utils.R new file mode 100644 index 0000000..aa2d588 --- /dev/null +++ b/tests/testthat/test-path-utils.R @@ -0,0 +1,34 @@ +# Create equivalent paths in different formats +p_fm <- a ~ b ~ c ~ b ~ a +p_ch <- c("a", "b", "c", "b", "a") +p_ls <- as.list(p_ch) +p_df <- data.frame( + c("a", "b", "c", "b"), + c("b", "c", "b", "a"), + fix.empty.names = FALSE +) + +p_list <- list(p_fm, p_ch, p_ls, p_df) + + +test_that("Ordinary .check_path() classes are equivalent", { + res <- do.call(rbind.data.frame, lapply(p_list, .check_path)) + + expect_all_true(res$info == "detailed") + expect_all_false(res$complex) + expect_identical(res$class, c("formula", "character", "list", "data.frame")) +}) + + +# Only two formats can express complex paths +c_fm <- a + b ~ c + d ~ d + e +c_ls <- list(c("a", "b"), c("c", "d"), c("d", "e")) + +c_list <- list(c_fm, c_ls) + +test_that("Complex .check_path() classes are equivalent", { + res <- do.call(rbind.data.frame, lapply(c_list, .check_path)) + expect_all_true(res$info == "detailed") + expect_all_true(res$complex) + expect_identical(res$class, c("formula", "list")) +}) diff --git a/tests/testthat/test-weave-formula-utils.R b/tests/testthat/test-weave-formula-utils.R index 93c21d3..02b5e04 100644 --- a/tests/testthat/test-weave-formula-utils.R +++ b/tests/testthat/test-weave-formula-utils.R @@ -1,6 +1,6 @@ -test_that("complex formula is parsing works", { +test_that("Detailed formula parsing works", { f <- a ~ b + c ~ d + e + f ~ g - res <- lapply(.path_prep_complex(f), deparse1) + res <- lapply(.path_prep_fm_detailed(f), deparse1) expect_identical( res, list("a ~ b + c", "b + c ~ d + e + f", "d + e + f ~ g") ) From 1e1e13284cec2c92980e3a6843db9d8795329e5d Mon Sep 17 00:00:00 2001 From: thomaz Date: Wed, 15 Jul 2026 23:10:09 +0200 Subject: [PATCH 2/2] Finish refactoring .path --- R/path-utils.R | 32 ++++++++++++++++++-------------- R/select_path.R | 8 +++++++- R/weave-coverage.R | 14 +++++++++----- R/weave.R | 2 +- tests/testthat/test-path-utils.R | 2 +- 5 files changed, 36 insertions(+), 22 deletions(-) diff --git a/R/path-utils.R b/R/path-utils.R index 90bf982..0993d57 100644 --- a/R/path-utils.R +++ b/R/path-utils.R @@ -62,6 +62,8 @@ include <- unlist(std_path[-c(1, length(std_path))], FALSE, FALSE) if(!length(include)) { include <- NULL } full_path <- .select_path( x, terms, include ) + + return(full_path) } @@ -107,6 +109,21 @@ } } +#' Standardize terms +#' @importFrom rlang f_lhs f_rhs +#' @returns a list of length 2 containing character vectors of y, x. +#' @noRd +#' +.path_parse_formula <- function(.path) { + stopifnot( "'.path' must be a formula." = inherits(.path, "formula")) + y_vars <- rlang::f_lhs(.path) + x_vars <- rlang::f_rhs(.path) + if( is.null(y_vars) || is.null(x_vars) ) { + stop("Neither formula side can be empty.") + } + lapply(list(y_vars, x_vars), all.vars) +} + #' @importFrom rlang as_label #' @noRd @@ -129,18 +146,5 @@ } -#' Standardize terms -#' @importFrom rlang f_lhs f_rhs -#' @returns a list of length 2 containing character vectors of y, x. -#' @noRd -#' -.path_parse_formula <- function(.path) { - stopifnot( "'.path' must be a formula." = inherits(.path, "formula")) - y_vars <- rlang::f_lhs(.path) - x_vars <- rlang::f_rhs(.path) - if( is.null(y_vars) || is.null(x_vars) ) { - stop("Neither formula side can be empty.") - } - lapply(list(y_vars, x_vars), all.vars) -} + diff --git a/R/select_path.R b/R/select_path.R index c7ecda6..544d732 100644 --- a/R/select_path.R +++ b/R/select_path.R @@ -27,7 +27,13 @@ select_path <- function( x, .path, include = NULL, exclude = NULL, exact = NULL, as.edges = FALSE ) { - paths <- .select_path(x, .path_parse(.path), include, exclude, exact) + path_check <- .check_path(.path) + .path_check_valid_weave(path_check) + + path_list <- .std_path_to_list(x, .path, path_check) + paths <- .select_std_path(x, path_list) + + #paths <- .select_path(x, .path_parse(.path), include, exclude, exact) if( as.edges ) paths <- lapply(paths, .V_path_as_E_path) return(paths) diff --git a/R/weave-coverage.R b/R/weave-coverage.R index fa31bc5..738ad31 100644 --- a/R/weave-coverage.R +++ b/R/weave-coverage.R @@ -49,12 +49,10 @@ weave_coverage <- function( path_check <- .check_path(.path) - if(path_check[["complex"]]) { - stop("weave_coverage() '.path' cannot contain '+'.\n", - "Use stack() to prepare input.") - } + .path_check_valid_coverage(path_check) - full_path <- .path_ordinary_to_full(x, .path)[[1L]] + path_list <- .std_path_to_list(x, .path, path_check) + full_path <- .select_std_path(x, path_list)[[1L]] stopifnot( "weave_coverage() '.path' must be 2 or 3 steps long." = @@ -74,6 +72,12 @@ weave_coverage <- function( } +.path_check_valid_coverage <- function(path_check) { + if(path_check[["complex"]]) { + stop("weave_coverage() '.path' cannot contain '+'.\n", + "Use stack() to prepare input.") + } +} .weave_contingency_params <- function(x) { shared <- do.call(intersect, unname(lapply(x, names))) diff --git a/R/weave.R b/R/weave.R index b82a30c..d69dd77 100644 --- a/R/weave.R +++ b/R/weave.R @@ -33,8 +33,8 @@ S7::method(weave, MultiFactor) <- function( lv_list <- levels(x) path_check <- .check_path(.path) - .path_check_valid_weave(path_check) + path_list <- .std_path_to_list(x, .path, path_check) full_path <- .select_std_path(x, path_list)[[1L]] # full_path <- .path_ordinary_to_full(x, .path)[[1L]] diff --git a/tests/testthat/test-path-utils.R b/tests/testthat/test-path-utils.R index aa2d588..c2118a0 100644 --- a/tests/testthat/test-path-utils.R +++ b/tests/testthat/test-path-utils.R @@ -20,7 +20,7 @@ test_that("Ordinary .check_path() classes are equivalent", { }) -# Only two formats can express complex paths +# Only two formats (formula & list) can express complex paths c_fm <- a + b ~ c + d ~ d + e c_ls <- list(c("a", "b"), c("c", "d"), c("d", "e"))