Harmonize and generally improve path handling

R/AllClasses.R

@@ -27,23 +27,23 @@
 #' @seealso [MultiFactor()]
 #' @export
 #'
 LinkMap <- S7::new_class(
     "LinkMap",
     package = "MultiFactor",
     parent = S7::class_data.frame,
     properties = list(
         levels = S7::new_property(
             getter = function(self) lapply(S7::S7_data(self), levels),
             setter = function(self, value) {
                 x <- `class<-`(S7::S7_data(self), "data.frame")
                 S7::S7_data(self) <- .unify_levels_LinkMap(x, value)
                 return(self)
             }
         ),
         metadata = S7::new_property(
             class = S7::class_data.frame,
             getter = function(self) self@metadata
         )
     ),
     constructor = function(x, metadata = NULL) {
         # Check input
@@ -54,7 +54,6 @@
             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 @@
         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) {

R/path-utils.R

@@ -1,42 +1,87 @@
+#' 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 )
+
+    return(full_path)
+}
+
+
+#' @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 +92,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,27 +109,6 @@
     }
 }
 
-#' @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
-}
-
-#' @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))
-    lapply(
-        seq_len(length(all_terms) -1L),
-        function(i) stats::reformulate(all_terms[i+1L], all_terms[i])
-        )
-    }
-
-
 #' Standardize terms
 #' @importFrom rlang f_lhs f_rhs
 #' @returns a list of length 2 containing character vectors of y, x.
@@ -106,3 +124,27 @@
     lapply(list(y_vars, x_vars), all.vars)
 }
 
+
+#' @importFrom rlang as_label
+#' @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_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])
+    )
+}
+
+
+
+

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)

R/stack.R

@@ -34,27 +34,31 @@ 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)
     }
     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,

R/weave-coverage.R

@@ -47,13 +47,12 @@ 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") {
-        stop("weave_coverage() '.path' cannot contain '+'.\n",
-             "Use stack() to prepare input.")
-    }
-    full_path <- .path_ordinary_to_full(x, .path)[[1L]]
+    .path_check_valid_coverage(path_check)
+
+    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." =
@@ -73,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)))

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)
+  .path_check_valid_weave(path_check)
 
-  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_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.

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 (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"))
+
+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"))
+})