Updated LinkMap @metadata to be its own slot. Improved @levels behavi…

DESCRIPTION

@@ -10,20 +10,19 @@ Authors@R: c(
 Description: An S7 framework to organize and manage multiple sets of factors, 
     for instance when tracing or converting feature IDs across databases. 
     Methods for MultiFactor aim to follow factor behaviour.
+Depends: 
+    R (>= 4.1.0)
 Imports:
-    S7, 
+    S7,
     rlang,
     generics,
-    Matrix, 
-    forcats, 
+    Matrix,
+    forcats,
     igraph
-Depends: 
-    R (>= 4.1.0)
 License: GPL-3
 LazyData: false
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.3
 Suggests: 
     anansi,
     ggplot2,
@@ -36,3 +35,4 @@ Suggests:
 Config/testthat/edition: 3
 URL: https://minotau-r.github.io/MultiFactor/
 VignetteBuilder: knitr
+Config/roxygen2/version: 8.0.0

NAMESPACE

@@ -1,7 +1,9 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[","MultiFactor::LinkMap")
 S3method("[<-","MultiFactor::MultiFactor")
 S3method("[[<-","MultiFactor::MultiFactor")
+S3method("levels<-","MultiFactor::LinkMap")
 S3method("levels<-","MultiFactor::MultiFactor")
 S3method(as.igraph,"MultiFactor::LinkMap")
 S3method(as.igraph,"MultiFactor::MultiFactor")
@@ -51,8 +53,10 @@ importFrom(igraph,induced_subgraph)
 importFrom(igraph,sample_gnm)
 importFrom(igraph,shortest_paths)
 importFrom(rlang,as_label)
+importFrom(rlang,check_dots_empty0)
 importFrom(rlang,f_lhs)
 importFrom(rlang,f_rhs)
+importFrom(rlang,is_missing)
 importFrom(stats,fisher.test)
 importFrom(stats,reformulate)
 importFrom(utils,count.fields)

R/AllClasses.R

@@ -11,6 +11,8 @@
 #'     application-specific tags.
 #' @param x `data.frame` with two named columns that can be coerced to factors.
 #'     Optionally, additional columns will be stored as metadata.
+#' @param metadata Optional `data.frame` with same number of rows as x. Contains
+#'     information about the feature link in that row.
 #' @returns a `LinkMap` object.
 #' @examples
 #' # Generate random linkage input
@@ -25,44 +27,53 @@
 #' @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)[c(1, 2)], levels
-            )
+            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(
-            getter = function(self) `class<-`(
-                S7::S7_data(self), "data.frame"
-            )[-c(1, 2)]
+            class = S7::class_data.frame,
+            getter = function(self) self@metadata
         )
     ),
-    constructor = function(x) {
-        if(S7::S7_inherits(x, LinkMap)) return(x)
+    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")
+            }
+        if(!NCOL(metadata)) {
+            metadata <- data.frame(row.names = seq_len(NROW(x)))
+        } else {
+            stopifnot(
+                "Arg 'x' must have the same number of rows as 'metadata'" =
+                    NROW(x) == NROW(metadata)
+            )
+        }
         # Factorize x
-        x[ c(1, 2)] <- lapply(x[c(1, 2)], as.factor)
-        x <- x[ !duplicated(x[, c(1, 2)]), ]
+        x[] <- lapply(x, factor)
+        i <- !duplicated(x)
+        x <- x[i, , drop = FALSE]
+        metadata <- metadata[i, , drop = FALSE]
 
-        S7::new_object(x)
-    },
+        S7::new_object(x, metadata = metadata)
+        },
     validator = function(self) {
-        if(!is.data.frame(self)) {
-            "Must be a data.frame. "
-        }
-        if(! NCOL(self) == 2L) {
-            "Must be a data.frame with exactly two columns. "
-        }
-        if(!length(colnames(self)) == 2L) {
-            "Both columns must be named. "
-        }
-        if(!all(vapply(self[c(1, 2)], is.factor, NA, USE.NAMES = FALSE))){
-            "Both columns must be factors. "
+        if( !is.data.frame(self) ) { "Must be a data.frame." }
+        if( NCOL(self) != 2L ) { "Must be a data.frame with two columns." }
+        if( length(colnames(self)) != 2L ) { "Both columns must be named." }
+        if( !all(vapply(self, is.factor, NA, USE.NAMES = FALSE)) ) {
+            "Both columns must be factors."
         }
     }
 )
@@ -115,8 +126,18 @@
     parent = S7::class_list,
     properties  = list(
         levels = S7::new_property(
-            class = S7::class_list, getter = function(self) self@levels,
-             setter = function(self, value) .set_levels_MultiFactor(self, value)
+            class = S7::class_list,
+            getter = function(self) self@levels,
+            setter = function(self, value) {
+                # If initializing, don't re-unify
+                if( !length(levels(self)) ) {
+                    self@levels <- value
+                } else {
+                    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")
@@ -127,7 +148,7 @@
             )
         )
     ),
-    constructor = function(x, levels = NULL) {
+    constructor = function(x, levels = list()) {
         # Check input
         if(is.data.frame(x)) x <- LinkMap(x)
         if(S7::S7_inherits(x, LinkMap)) x <- list(x = x)
@@ -140,7 +161,7 @@
         names(x) <- paste0("x_", seq_along(x))
         x   <- .merge_linkmaps(x)
 
-        if(is.null(levels))  levels <- .build_levels(x)
+        if( !length(levels) )  levels <- .build_levels_from_linkmap_list(x)
         x <- .unify_levels(x, levels)
 
         names(x) <- vapply(
@@ -150,7 +171,7 @@
         )
 
         S7::new_object(
-            .parent = x,
+            x,
             levels = levels
         )
     },
@@ -169,10 +190,10 @@
     if(! is.data.frame(x) ) {
         stop("Must be a data.frame. ")
     }
-    if(! NCOL(x) >= 2L ) {
+    if(! NCOL(x) == 2L ) {
         stop("Must be a data.frame with at least two key columns. ")
     }
-    if(! length(colnames(x)[seq_len(2L)]) == 2L ) {
+    if(! length(colnames(x)) == 2L ) {
         stop("Both key columns must be named. ")
     }
     return( TRUE )
@@ -208,7 +229,7 @@
     mx <- switch(mode,
                  "counts" = unlist(
                      lapply(x, function(y) {
-                         lapply(y[seq_len(2L)], function(z) length(unique(z)))
+                         lapply(y, function(z) length(unique(z)))
                      }),
                      use.names = FALSE
                  ),
@@ -231,7 +252,7 @@
 
 
 .merge_linkmaps <- function(x) {
-    all_names <- lapply(x, \(x) sort(names(x)))
+    all_names <- lapply(x, function(x) sort(names(x)))
     if(!any(duplicated(all_names))) return(x)
 
     dup_names <- unique(all_names[duplicated(all_names)])
@@ -305,7 +326,15 @@
 
 #' Given a list of linkmaps x, return a unified and sorted list of levels.
 #' @noRd
-.build_levels <- function(x) {
+.build_levels_from_df_list <- function(x) {
+    all_lvs <- unique(unlist(lapply(x, colnames), FALSE, FALSE))
+    lvs <- .gather_all_levels(x, all_lvs)
+    return(lvs)
+}
+
+#' Given a list of linkmaps x, return a unified and sorted list of levels.
+#' @noRd
+.build_levels_from_linkmap_list <- function(x) {
     all_lvs <- unique(unlist(lapply(x, colnames), FALSE, FALSE))
     lvs <- .gather_all_levels(x, all_lvs)
     return(lvs)
@@ -334,19 +363,25 @@
 #' @noRd
 .unify_levels <- function(x, levels) lapply(x, .unify_levels_LinkMap, levels)
 
+
+# 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[seq_len(2L)], levels[colnames(x)], SIMPLIFY = FALSE
+        forcats::lvls_expand,
+        x,
+        levels[colnames(x)],
+        SIMPLIFY = FALSE
     )
     return(x)
 }
 
 .validLinkMap <- function(x) {
     is.data.frame(x) &&
-        NCOL(x) == 2L &&
-        length(colnames(x)) == 2L &&
+        NCOL(x) >= 2L &&
+        length(colnames(x)) >= 2L &&
         all(vapply(x[seq_len(2L)], is.factor, NA, USE.NAMES = FALSE))
 }
 

R/LinkMap-methods.R

@@ -24,28 +24,6 @@
 #' @returns A `LinkMap`
 NULL
 
-S7::method(names, LinkMap) <- function(x) names(
-    S7::S7_data(x)[c(1, 2)]
-    )
-
-S7::method(dimnames, LinkMap) <- function(x) dimnames(
-    `class<-`(S7::S7_data(x), "data.frame")[c(1, 2)]
-    )
-
-S7::method(dim, LinkMap) <- function(x) dim(
-    `class<-`(S7::S7_data(x), "data.frame")[c(1, 2)]
-    )
-
-S7::method(print, LinkMap) <- function(x, ...) print(
-    `class<-`(S7::S7_data(x), "data.frame")[c(1, 2)], ...
-)
-
-S7::method(str, LinkMap) <- function(object, ...) str(
-    `class<-`(S7::S7_data(object), "data.frame")
-)
-
-S7::method(levels, LinkMap) <- function(x) lapply(x[c(1, 2)], levels)
-
 #' @param use.names `Boolean scalar` Should names be provided.
 #'     (Default: `TRUE`)
 #' @noRd
@@ -54,6 +32,45 @@ S7::method(nlevels, LinkMap) <- function(x, use.names = TRUE) lengths(
     levels(x), use.names
     )
 
+S7::method(levels, LinkMap) <- function(x) x@levels
+
+#' @export
+#'
+`levels<-.MultiFactor::LinkMap` <- function(x, value) {
+    x@levels <- value
+    return(x)
+}
+
+# S7::method(`levels<-`, LinkMap) <- function(x, value) {
+#     `levels<-.MultiFactor::LinkMap`(x, value)
+# }
+
+
+#' @importFrom rlang check_dots_empty0 is_missing
+#' @export
+#'
+`[.MultiFactor::LinkMap` <- function(x, i, ...) {
+    rlang::check_dots_empty0(...)
+    if(! rlang::is_missing(i))  {
+        metadata <- x@metadata
+        metadata <- `[.data.frame`(metadata, i, , drop = FALSE)
+
+        x <- `class<-`(S7::S7_data(x), "data.frame")
+        x <- `[.data.frame`(x, i, , drop = FALSE)
+
+        x <- LinkMap(x, metadata)
+        }
+    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.
 #' @name as.matrix.LinkMap
@@ -69,8 +86,8 @@ S7::method(nlevels, LinkMap) <- function(x, use.names = TRUE) lengths(
 #' @seealso [Matrix::sparseMatrix()]
 #'
 `as.matrix.MultiFactor::LinkMap` <- function(
-        x, terms = colnames(x),
-        dims = nlevels(x[terms]), dimnames = levels(x)[terms],
+        x, terms = colnames(x)[seq_len(2L)],
+        dims = nlevels(x)[terms], dimnames = levels(x)[terms],
         ...
 ) Matrix::sparseMatrix(
     i = x[[terms[1L]]], j = x[[terms[2L]]],

R/MultiFactor-methods.R

@@ -104,12 +104,10 @@ S7::method(print, MultiFactor) <- function(x, ...) {
 S7::method(levels, MultiFactor) <- function(x) {
     x@levels
 }
-
 #' @export
 `levels<-.MultiFactor::MultiFactor` <- function(x, value)
     .set_levels_MultiFactor(x, value)
 
-
 S7::method(dimnames, MultiFactor) <- function(x) {
     dimnames(x@map)
 }
@@ -155,7 +153,7 @@ S7::method(`[[`, MultiFactor) <- function(x, i) base::`[[`(S7::S7_data(x), i)
     lv_list <- lapply(x[mfs], levels)
     if(any(lms)) {
         lm_lst <- x[lms]
-        lv_list <- c(lv_list, list(.build_levels(lm_lst)))
+        lv_list <- c(lv_list, list(.build_levels_from_linkmap_list(lm_lst)))
     }
     all_lvs <- unique(unlist(lapply(lv_list, names), FALSE, FALSE))
     all_lvs <- .reduce_level_list(lv_list, all_lvs)

R/MultiFactor-wrangle-utils.R

@@ -77,4 +77,15 @@ S7::method(augment, MultiFactor) <-
     return(x)
 }
 
+#' Safely get all names from a MultiFactor as a data.frame.
+#' @noRd
+#'
+.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.VALUE = c(NA_character_, NA_character_))
+        )
+    )
+}