Improve internal handling of paths

NAMESPACE

@@ -12,25 +12,28 @@ S3method(as.matrix,"MultiFactor::LinkMap")
 S3method(augment,"MultiFactor::MultiFactor")
 S3method(c,"MultiFactor::MultiFactor")
 S3method(stack,"MultiFactor::MultiFactor")
+S3method(subset,"MultiFactor::LinkMap")
 S3method(subset,"MultiFactor::MultiFactor")
+S3method(terms,"MultiFactor::factor_path")
 S3method(unique,"MultiFactor::LinkMap")
 export(LinkMap)
 export(MultiFactor)
 export(as.LinkMap)
 export(as.MultiFactor)
 export(draw_cards)
+export(factor_path)
 export(mf_as_graph_df)
 export(nlevels)
 export(poker_scores)
 export(randomLinkMap)
 export(randomMultiFactor)
 export(read_adjacency_list)
 export(select_path)
-export(subgroup_apply)
-export(subgroup_to_tbl)
 export(trade_posts)
 export(weave)
+export(weave_apply)
 export(weave_coverage)
+export(weave_to_tbl)
 if (getRversion() < "4.3.0") importFrom("S7", "@")
 import(S7)
 importFrom(Matrix,colSums)
@@ -42,7 +45,10 @@ importFrom(Matrix,which)
 importFrom(S7,"prop<-")
 importFrom(S7,S7_data)
 importFrom(S7,S7_dispatch)
+importFrom(S7,class_character)
 importFrom(S7,new_class)
+importFrom(S7,new_generic)
+importFrom(S7,new_object)
 importFrom(S7,new_property)
 importFrom(forcats,lvls_expand)
 importFrom(forcats,lvls_union)
@@ -66,6 +72,7 @@ importFrom(rlang,f_lhs)
 importFrom(rlang,f_rhs)
 importFrom(rlang,is_missing)
 importFrom(stats,reformulate)
+importFrom(stats,terms)
 importFrom(utils,count.fields)
 importFrom(utils,data)
 importFrom(utils,download.file)

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
@@ -182,7 +182,62 @@
 
 )
 
-##### LinkMap utils ----
+
+#' factor_path S7 class
+#' @name factor_path
+#' @rdname factor_path-class
+#' @description
+#' `factor_path` is an S7 class to standardize the various ways in which paths
+#' that can be specified across the `MultiFactor` package. This class is mostly
+#' for internal use.
+#'
+#' @param x `Character vector` of length two; `c(<from>, <to>)`.
+#' @param include `List of character vectors`. Which elements are included in
+#'     the path? Length of the list indicates number of paths.
+#' @param exclude `Character vector`. Which elements are excluded from the path?
+#' @param exact `Logical`. Should the path be followed as is?
+#'     (i.e., no pathfinding required)
+#' @returns a `factor_path` object.
+#' @importFrom S7 new_class new_property class_character new_object
+#' @examples
+#' factor_path(x = c("a", "c"), include = list("b"))
+#' @export
+#'
+factor_path <- S7::new_class(
+    "factor_path",
+    package = "MultiFactor",
+    parent = S7::class_character,
+    properties  = list(
+        include = S7::new_property(
+            class = S7::class_list, default = list(character())
+        ),
+        exclude = S7::new_property(
+            class = S7::class_character, default = character()
+        ),
+        exact   = S7::new_property(
+            class = S7::class_logical, default = FALSE
+        )
+    ),
+    constructor = function(
+        x, include = list(character()), exclude = character(), exact = FALSE
+    ) {
+        stopifnot(
+            "factor_path input must be length 2." = length(x) == 2L,
+            "factor_path input must be a character vector." = is.character(x)
+        )
+        S7::new_object(
+            .parent = x, include = include, exclude = exclude, exact = exact
+        )
+    },
+    validator = function(self) {
+        if(length(S7::S7_data(self)) != 2L) {
+            "factor_path must have length of two. "
+        }
+    }
+)
+
+
+##### LinkMap utils --]--
 
 .check_input_df <- function(x) {
     if(! is.data.frame(x) ) {

R/AllGenerics.R

@@ -1,10 +1,11 @@
 #' Convert common classes to LinkMap
 #' @export
-#' @rdname as.LinkMap-generic
+#' @rdname as.LinkMap
 #' @name as.LinkMap
 #' @param x input object
 #' @param ... additional arguments
 #' @seealso [as.LinkMap-methods]
+#' @returns a `LinkMap`
 #' @examples
 #' # Available methods:
 #' as.LinkMap
@@ -13,7 +14,7 @@ as.LinkMap <- S7::new_generic("as.LinkMap", "x")
 
 #' The Number of Levels of an Object
 #' @name nlevels
-#' @rdname nlevels-generic
+#' @rdname nlevels
 #' @description
 #' Return the number of levels which its argument has. Extends `base::nlevels`.
 #' @param x an object, such as a `LinkMap`, `MultiFactor` or `factor`.
@@ -31,27 +32,31 @@ S7::method(nlevels, S7::class_any) <- base::nlevels
 
 #' Convert common classes to MultiFactor
 #' @export
-#' @rdname as.MultiFactor-generic
+#' @rdname as.MultiFactor
 #' @name as.MultiFactor
 #' @param x input object
 #' @param ... additional arguments
-#' @seealso [as.LinkMap-methods]
+#' @returns a `MultiFactor`.
+#' @seealso [as.LinkMap]
 #' @examples
 #' # Available methods:
 #' as.MultiFactor
 #'
-#'
 as.MultiFactor <- S7::new_generic("as.MultiFactor", "x")
 
-#' Convert common classes to MultiFactor
-#' @export
+#' Weave a path through an object
 #' @rdname weave-generic
-#' @name weave
+#' @name weave-generic
+#' @description `weave()` is an S7 generic that finds a path through a
+#'     relational object.
+#'
 #' @param x input object
 #' @param .path either a `formula` or a `character vector` of length 2 with the
 #'     names of the desired combination of feature types.
 #' @param ... additional arguments
+#' @returns a `LinkMap` or `matrix`.
 #' @importFrom S7 S7_dispatch
+#' @export
 #' @examples
 #' # Available methods:
 #' weave
@@ -60,4 +65,50 @@ weave <- S7::new_generic("weave", "x", function(x, .path, ...) {
     S7::S7_dispatch()
 })
 
+#' Index a table and apply arbitrary code to it
+#' @rdname weave_apply-generic
+#' @name weave_apply-generic
+#' @description `weave_apply()` is an S7 generic that finds a path through a
+#'     relational object and evaluates provided code to each corresponding
+#'     subset of an input table.
+#'
+#' @param .x input relational object to dispatch on.
+#' @param .path either a `formula` or a `character vector` of length 2 with the
+#'     names of the desired combination of feature types.
+#' @param .data an R object, such as tabular data.
+#' @param .fun the function to be applied to each subgroup of `.x`.
+#' @param ... Optional arguments to `.fun`
+#' @importFrom S7 S7_dispatch new_generic
+#' @export
+#' @returns a list containing the results of `.fun`.
+#' @examples
+#' # Available methods:
+#' weave_apply
+#'
+weave_apply <- S7::new_generic(
+    "weave_apply",
+    ".x",
+    function(.x, .path, .data, .fun = NULL, ...) {S7::S7_dispatch()}
+)
+
+#' Weave a path through an object
+#' @name select_path-generic
+#' @rdname select_path-generic
+#' @description `select_path()` is an S7 generic that finds and returns a path
+#'     through a relational object.
+#'
+#' @param x input object
+#' @param .path either a `formula` or a `character vector` of length 2 with the
+#'     names of the desired combination of feature types.
+#' @param ... additional arguments
+#' @export
+#' @importFrom S7 S7_dispatch
+#' @returns a (list of) character vector(s).
+#' @examples
+#' # Available methods:
+#' select_path
+#'
+select_path <- S7::new_generic("select_path", "x", function(x, .path, ...) {
+    S7::S7_dispatch()
+})
 

R/LinkMap-methods.R

@@ -109,6 +109,9 @@ S7::method(levels, LinkMap) <- function(x) x@levels
 #' @returns a sparse biadjacency `Matrix` with
 #' @export
 #' @seealso [Matrix::sparseMatrix()]
+#' @examples
+#' x <- randomLinkMap()
+#' as.matrix(x)
 #'
 `as.matrix.MultiFactor::LinkMap` <- function(
         x, terms = colnames(x),
@@ -137,6 +140,9 @@ S7::method(levels, LinkMap) <- function(x) x@levels
 #' @param row.names,optional,... For compatibility, not currently used.
 #' @importFrom S7 S7_data
 #' @returns a `data.frame`
+#' @examples
+#' x <- randomLinkMap()
+#' as.data.frame(x)
 #' @export
 #'
 `as.data.frame.MultiFactor::LinkMap` <- function(
@@ -148,14 +154,6 @@ S7::method(levels, LinkMap) <- function(x) x@levels
 
 ##### LinkMap utils
 
-#' @noRd
-.formula2name <- function(.path) {
-   var_list <- .path_parse_formula(.path)
-   var_vctr <- vapply(var_list, paste, collapse = ".", FUN.VALUE = character(1L))
-   var_name <- paste(var_vctr, collapse = "2")
-   return(var_name)
-}
-
 .colnames2name <- function(x) paste(x, collapse = "2")
 
 .linkmap2name <- function(x) paste(names(x), collapse = "2")

R/as.LinkMap.R

@@ -50,7 +50,7 @@ S7::method(as.LinkMap, S7::class_data.frame) <- function(
         x, edge.names = NULL
 ){
     if( NCOL(x) >= 3L ) {
-        metadata <- x[, -seq_len(2L)]
+        metadata <- x[, -seq_len(2L), drop = FALSE]
         x <- x[, seq_len(2L)]
     } else {
         metadata <- data.frame(row.names = seq_len(NROW(x)))

R/augment-subset.R

@@ -26,32 +26,59 @@
 #'
 NULL
 
+
+
 #' @export
-#' @aliases subset.MultiFactor
 #'
 `subset.MultiFactor::MultiFactor` <- function(
-        x, subset = NULL, by_path = TRUE, drop.unmatched = TRUE, ...
+        x, .path, .drop.unmatched = FALSE, ...
 ) {
-    if(drop.unmatched) x <- .trimMultiFactor(x)
-    if(is.null(subset)) return(x)
-    if(by_path){
-        subset <- unlist(.path_parse(subset))
-        stopifnot("Argument `subset` must be length 2 if by_path` is TRUE" =
-                      length(subset) == 2L)
-        subset <- termSeq(subset, x)
-        # Determine required ids in order, keep relevant elements of MultiFactor
-        return(subsetByPath(x, subset))
-    } else `[`(x, subset)
+    if(.drop.unmatched) x <- .trimMultiFactor(x)
+
+    path_check <- .check_path(.path)
+    .path_check_valid_subset(path_check)
+    path_list <- .path_to_std_list(.path, path_check)
+
+    path_list <- .path_to_std_list(.path, path_check)
+
+    full_path <- unlist(as.list(.select_std_path(x, path_list)), FALSE, FALSE)
+
+    x <- .subset_by_path(x, full_path)
+    return(x)
 }
 
 #' @export
 #'
+`subset.MultiFactor::LinkMap` <- function(x, subset = NULL, ...) {
+    df <- as.data.frame(x)
+    if( is.null(subset) ) {
+        if("complete" %in% colnames(df)) {
+            i <- df[["complete"]] } else {
+                i <-  rep_len(TRUE, NCOL(df))
+            }
+    } else {
+        e <- substitute(subset)
+        i <- eval(e, df, enclos = parent.frame())
+    }
+    res <- x[i]
+    return(res)
+}
+
+.path_check_valid_subset <- function(path_check) {
+    if(path_check[["complex"]]) {
+        stop(
+            "subset() '.path' cannot contain '+'.",
+            "Use `stack()` to prepare input."
+        )
+        }
+    }
+
 method(subset, MultiFactor) <-
     function(
-        x, subset = NULL, by_path = TRUE, drop.unmatched = TRUE, ...
-    ) `subset.MultiFactor::MultiFactor`(
-        x, subset, by_path, drop.unmatched, ...
-    )
+        x, .path, .drop.unmatched = FALSE, ...
+        ) `subset.MultiFactor::MultiFactor`(
+            x, .path, .drop.unmatched
+        )
 
 
 #' @importFrom generics augment

R/data.R

@@ -8,6 +8,7 @@
 #'     prefix.
 #' @source `trade_goods`: Curated using the `emo` package.
 #' @usage data("trade_goods", package = "MultiFactor")
+#' @keywords datasets
 #'
 "trade_goods"
 
@@ -19,5 +20,6 @@
 #'     vignette.
 #' @source `playing_cards`: Manual input.
 #' @usage data("playing_cards", package = "MultiFactor")
+#' @keywords datasets
 #'
 "playing_cards"