Weave complex

NAMESPACE

@@ -10,7 +10,9 @@ S3method(as.igraph,"MultiFactor::MultiFactor")
 S3method(as.matrix,"MultiFactor::LinkMap")
 S3method(augment,"MultiFactor::MultiFactor")
 S3method(c,"MultiFactor::MultiFactor")
+S3method(stack,"MultiFactor::MultiFactor")
 S3method(subset,"MultiFactor::MultiFactor")
+S3method(unique,"MultiFactor::LinkMap")
 export(LinkMap)
 export(MultiFactor)
 export(as.LinkMap)
@@ -33,6 +35,7 @@ importFrom(Matrix,rowSums)
 importFrom(Matrix,sparseMatrix)
 importFrom(Matrix,t)
 importFrom(Matrix,which)
+importFrom(S7,"prop<-")
 importFrom(S7,S7_dispatch)
 importFrom(S7,new_class)
 importFrom(S7,new_property)
@@ -54,6 +57,7 @@ importFrom(igraph,sample_gnm)
 importFrom(igraph,shortest_paths)
 importFrom(rlang,as_label)
 importFrom(rlang,check_dots_empty0)
+importFrom(rlang,dots_list)
 importFrom(rlang,f_lhs)
 importFrom(rlang,f_rhs)
 importFrom(rlang,is_missing)
@@ -62,4 +66,5 @@ importFrom(stats,reformulate)
 importFrom(utils,count.fields)
 importFrom(utils,data)
 importFrom(utils,download.file)
+importFrom(utils,stack)
 importMethodsFrom(Matrix,"%&%")

R/AllClasses.R

@@ -27,31 +27,34 @@
 #' @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
         stopifnot(.check_input_df(x))
+
+
         if(S7::S7_inherits(x, LinkMap)) {
             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 {
@@ -136,8 +139,7 @@
                     self <- .set_levels_MultiFactor(self, value)
                 }
                 return(self)
-            },
-            default = quote(as.list(colnames(self)))
+            }
             ),
         map = S7::new_property(
             getter = function(self) .mapMultiFactor(self, mode = "counts")
@@ -164,11 +166,7 @@
         if( !length(levels) )  levels <- .build_levels_from_linkmap_list(x)
         x <- .unify_levels(x, levels)
 
-        names(x) <- vapply(
-            x,
-            function(x) paste(names(x), collapse = "2"),
-            FUN.VALUE = "", USE.NAMES = FALSE
-        )
+        names(x) <- vapply(x, .linkmap2name, FUN.VALUE = "", USE.NAMES = FALSE)
 
         S7::new_object(
             x,
@@ -289,7 +287,7 @@
 
         # Filter feature ids in each df to only universally shared ones.
         x[ii] <- lapply(x[ii], function(df) {
-            return(df[df[[j]] %in% keep, ])
+            return(df[df[[j]] %in% keep ])
         })
     }
     return(x)
@@ -361,27 +359,47 @@
 #' Given a list of linkmaps x and named list of chars levels, unify all levels
 #' across x.
 #' @noRd
-.unify_levels <- function(x, levels) lapply(x, .unify_levels_LinkMap, levels)
+.unify_levels <- function(x, levels) {
+    is_s7 <- all(vapply(x, S7::S7_inherits, LinkMap, FUN.VALUE = FALSE))
+    if(is_s7) {
+        res <- lapply(x, .unify_levels_LinkMap, levels)
+    } else {
+        res <- lapply(x, .unify_levels_data.frame, levels)
+    }
+    return(res)
+}
+
+#' @importFrom forcats lvls_expand
+#'
+.unify_levels_data.frame <- function(x, levels) {
+    x <- mapply(
+        forcats::lvls_expand, x,
+        levels, SIMPLIFY = FALSE
+    )
+    return(x)
+}
 
 
 # TODO metadata and .data are now separate props. Use lapply for indexing?
 # FIXME
 #' @importFrom forcats lvls_expand
 #'
 .unify_levels_LinkMap <- function(x, levels) {
+
     x[] <- mapply(
         forcats::lvls_expand,
         x,
         levels[colnames(x)],
         SIMPLIFY = FALSE
     )
+    #S7::S7_data(x) <- `class<-`(old, "data.frame")
     return(x)
 }
 
 .validLinkMap <- function(x) {
     is.data.frame(x) &&
-        NCOL(x) >= 2L &&
-        length(colnames(x)) >= 2L &&
-        all(vapply(x[seq_len(2L)], is.factor, NA, USE.NAMES = FALSE))
+        NCOL(x) == 2L &&
+        length(colnames(x)) == 2L &&
+        all(vapply(x, is.factor, NA, USE.NAMES = FALSE))
 }
 

R/LinkMap-methods.R

@@ -41,10 +41,13 @@ S7::method(levels, LinkMap) <- function(x) x@levels
     return(x)
 }
 
-# S7::method(`levels<-`, LinkMap) <- function(x, value) {
-#     `levels<-.MultiFactor::LinkMap`(x, value)
-# }
-
+#' @export
+#'
+`unique.MultiFactor::LinkMap` <- function(x, incomparables = FALSE, ...) {
+  if (!isFALSE(incomparables))
+    .NotYetUsed("incomparables != FALSE")
+  x[! duplicated(x) ]
+}
 
 #' @importFrom rlang check_dots_empty0 is_missing
 #' @export
@@ -63,13 +66,6 @@ S7::method(levels, LinkMap) <- function(x) x@levels
     return(x)
 }
 
-S7::method(`[`, MultiFactor) <- function(x, i) {
-
-    MultiFactor(base::`[`(S7::S7_data(x), i))
-}
-
-S7::method(`[[`, MultiFactor) <- function(x, i) base::`[[`(S7::S7_data(x), i)
-
 
 #' @title Convert a LinkMap to a sparse matrix.
 #' Convert a LinkMap to a sparse matrix object from the `Matrix` package.
@@ -86,11 +82,27 @@ S7::method(`[[`, MultiFactor) <- function(x, i) base::`[[`(S7::S7_data(x), i)
 #' @seealso [Matrix::sparseMatrix()]
 #'
 `as.matrix.MultiFactor::LinkMap` <- function(
-        x, terms = colnames(x)[seq_len(2L)],
+        x, terms = colnames(x),
         dims = nlevels(x)[terms], dimnames = levels(x)[terms],
         ...
 ) Matrix::sparseMatrix(
     i = x[[terms[1L]]], j = x[[terms[2L]]],
     dims = dims, dimnames = dimnames,
     ...
 )
+
+
+
+##### 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/MultiFactor-methods.R

@@ -105,8 +105,9 @@ S7::method(levels, MultiFactor) <- function(x) {
     x@levels
 }
 #' @export
-`levels<-.MultiFactor::MultiFactor` <- function(x, value)
+`levels<-.MultiFactor::MultiFactor` <- function(x, value) {
     .set_levels_MultiFactor(x, value)
+}
 
 S7::method(dimnames, MultiFactor) <- function(x) {
     dimnames(x@map)
@@ -126,6 +127,7 @@ S7::method(`[[`, MultiFactor) <- function(x, i) base::`[[`(S7::S7_data(x), i)
 
 })
 
+
 #' @export
 #'
 `[<-.MultiFactor::MultiFactor` <- function(x, i, value) {

R/MultiFactor-wrangle-utils.R → R/augment-subset.R

@@ -1,6 +1,6 @@
 #' Tools to modify MultiFactors
-#' @name MultiFactor-wrangle-methods
-#' @rdname MultiFactor-wrangle-methods
+#' @name augment-subset
+#' @rdname augment-subset
 #' @description
 #' Generates a new `MultiFactor` object by cross-referencing the elements of a
 #'     given `MultiFactor`.
@@ -14,12 +14,14 @@
 #' # Generate a random MultiFactor
 #' x <- randomMultiFactor()
 #'
-#' # Use augment to build upon the same MultiFactor.
+#' # Use augment to chain together operations like weave and stack, in order.
 #' augment(x,
 #'     weave(x, a ~ c),
+#'     stack(x, a + b ~ c + d),
 #'     weave(x, d ~ f)
 #' )
-#' # Setting a LinkMap to NULL deletes it from the MultiFactor
+#'
+#' # Setting a LinkMap to NULL by name deletes it from the MultiFactor
 #' augment(x, a2b = NULL )
 #'
 NULL
@@ -33,7 +35,7 @@ NULL
     if(drop.unmatched) x <- .trimMultiFactor(x)
     if(is.null(subset)) return(x)
     if(by_path){
-        subset <- unlist(.path_terms(subset))
+        subset <- unlist(.path_parse(subset))
         stopifnot("Argument `subset` must be length 2 if by_path` is TRUE" =
                       length(subset) == 2L)
         subset <- termSeq(subset, x)
@@ -58,18 +60,21 @@ S7::method(augment, MultiFactor) <-
     function(x, ...) `augment.MultiFactor::MultiFactor`(x, ...)
 
 #' @export
-#' @rdname MultiFactor-wrangle-methods
+#' @rdname augment-subset
 #' @name augment.MultiFactor
+#' @importFrom rlang dots_list
 #'
 `augment.MultiFactor::MultiFactor` <- function(x, ...) {
     old_names <- rownames(x)
-    dots <- list(...)
+    dots <- rlang::dots_list(...)
     dot_names <- names(dots)
-
     for ( i in seq_along(dot_names) ) {
         res <- eval(dots[[i]])
-        if( dot_names[i] %in% old_names ) {
-            x[[dot_names[i]]] <- res
+        res_name <- dot_names[i]
+        if(res_name == "") { res_name <- .linkmap2name(res) }
+
+        if( res_name %in% old_names ) {
+            x[[res_name]] <- res
         } else {
             x <- c(x, res)
         }
@@ -83,7 +88,7 @@ S7::method(augment, MultiFactor) <-
 .all_names_in_list_mf <- function(x) {
     as.data.frame.matrix(
         t(vapply(X = x,
-                 FUN = function(i) return(names(i)[seq_len(2L)]),
+                 FUN = function(i) return(names(i)),
                  FUN.VALUE = c(NA_character_, NA_character_))
         )
     )

R/levels-utils.R

@@ -2,25 +2,21 @@
 #' @param x MultiFactor or appropriately formatted list
 #' @param levels A `named list of character vectors`, to be used as
 #'     replacement levels.
+#' @param merge A boolean. Whether to merge or overwrite (default) overlapping
+#'     levels
+#' @importFrom S7 prop<-
 #' @returns a MultiFactor with updated levels.
 #' @noRd
 #'
 .set_levels_MultiFactor <- function(x, levels) {
     all_lvs <- colnames(x)
     matched_lvs <- names(levels) %in% all_lvs
 
-    stopifnot( "No overlap in 'x' and 'levels'." = sum(matched_lvs) >= 1L )
-
     new_levels <- levels[matched_lvs]
-
-    unchanged <- ! all_lvs %in% names(levels)
-    if( sum(unchanged) >= 1L ) {
-        new_levels <- c( new_levels, .gather_all_levels(x, all_lvs[unchanged]) )
-    }
     S7::S7_data(x) <- .unify_levels(
         `class<-`(S7::S7_data(x), "data.frame"),
         new_levels
-        )
+    )
 
     return(x)
 }