fix coverage vignette

NAMESPACE

@@ -42,6 +42,7 @@ importFrom(Matrix,rowSums)
 importFrom(Matrix,sparseMatrix)
 importFrom(Matrix,t)
 importFrom(Matrix,which)
+importFrom(S7,"S7_data<-")
 importFrom(S7,"prop<-")
 importFrom(S7,S7_data)
 importFrom(S7,S7_dispatch)
@@ -50,6 +51,7 @@ importFrom(S7,new_class)
 importFrom(S7,new_generic)
 importFrom(S7,new_object)
 importFrom(S7,new_property)
+importFrom(forcats,as_factor)
 importFrom(forcats,lvls_expand)
 importFrom(forcats,lvls_union)
 importFrom(generics,augment)

R/AllClasses.R

@@ -25,6 +25,7 @@
 #' LinkMap(x)
 #'
 #' @seealso [MultiFactor()]
+#' @importFrom forcats as_factor
 #' @export
 #'
 LinkMap <- S7::new_class(
@@ -47,23 +48,22 @@ LinkMap <- S7::new_class(
     ),
     constructor = function(x, metadata = NULL) {
         # Check input
-        stopifnot(.check_input_df(x))
-
+        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)) {
+        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[] <- lapply(x, factor)
+        # Factorize x, preserve order
+        x[] <- lapply(x, forcats::as_factor)
         i <- !duplicated(x)
         x <- x[i, , drop = FALSE]
         x <- `row.names<-.data.frame`(x, NULL)

R/MultiFactor-methods.R

@@ -128,7 +128,7 @@ S7::method(dim, MultiFactor) <- function(x) {
 local({
 S7::method(`[`, MultiFactor) <- function(x, i) {
     if(rlang::is_missing(i)) return(x)
-    MultiFactor(base::`[`(S7::S7_data(x), i))
+    MultiFactor(base::`[`(S7::S7_data(x), i), levels = levels(x))
 }
 
 S7::method(`[[`, MultiFactor) <- function(x, i) base::`[[`(S7::S7_data(x), i)
@@ -182,7 +182,7 @@ S7::method(`[[`, MultiFactor) <- function(x, i) base::`[[`(S7::S7_data(x), i)
         function(lv) {
             res <- lapply(lv_list, `[[`, lv)
             res <- Reduce(union, res, init = character())
-            return( sort(res) )
+            return( res )
         }
     )
     names(res) <- all_lvs

R/as.LinkMap.R

@@ -65,18 +65,18 @@ S7::method(as.LinkMap, S7::class_data.frame) <- function(
 }
 
 S7::method(as.LinkMap, S7::class_list) <- function(
-    x, y = NULL, edge.names = NULL ){
+    x, y = NULL, edge.names = NULL ) {
     # Use list names
-    if( is.null(y) ){
+    if( is.null(y) ) {
         y <- names(x)
     }
     # Create linkMap
     x2y <- data.frame(
         x = unlist(x, recursive = TRUE, use.names = FALSE),
         y = rep(y, lengths(x))
-    )
+        )
     # Assign custom edge names
-    if( !is.null(edge.names) ){
+    if( !is.null(edge.names) ) {
         names(x2y) <- edge.names
     }
     # Convert to LinkMap

R/levels-utils.R

@@ -4,7 +4,7 @@
 #'     replacement levels.
 #' @param merge A boolean. Whether to merge or overwrite (default) overlapping
 #'     levels
-#' @importFrom S7 prop<-
+#' @importFrom S7 prop<- S7_data<-
 #' @returns a MultiFactor with updated levels.
 #' @noRd
 #'
@@ -13,10 +13,7 @@
     matched_lvs <- names(levels) %in% all_lvs
 
     new_levels <- levels[matched_lvs]
-    S7::S7_data(x) <- .unify_levels(
-        `class<-`(S7::S7_data(x), "data.frame"),
-        new_levels
-    )
+    S7::S7_data(x) <- .unify_levels( S7::S7_data(x), new_levels )
 
     return(x)
 }

R/playing_cards.R

@@ -38,7 +38,10 @@ poker_scores <- function() {
     suits <- pq$suits
 
     # Define scores as lists
-    multiples <- split(deck, f = rep(ranks, length(suits)))
+    multiples <- split(
+        deck,
+        f = factor(rep(ranks, length(suits)), levels = ranks)
+        )
     flushes   <- split(deck, f = rep(names(suits), each = length(ranks)))
     straights <- lapply(
         seq_len(10L),
@@ -48,9 +51,16 @@ poker_scores <- function() {
     names(straights)[10L] <- "Royal straight"
 
     # Convert to LinkMaps
-    card2rank <- as.LinkMap(multiples, edge.names = c("card", "rank"))
-    card2suit <- as.LinkMap(flushes, edge.names = c("card", "suit"))
-    rank2straights <- as.LinkMap(straights, edge.names = c("rank", "straight"))
+    card2rank <- stack(multiples)
+    colnames(card2rank) <- c("card", "rank")
+    levels(card2rank$card) <- deck
+
+    card2suit <- stack(flushes)
+    colnames(card2suit) <- c("card", "suit")
+    levels(card2suit$card) <- deck
+
+    rank2straights <- stack(straights)
+    colnames(rank2straights) <- c("rank", "straight")
 
     x <- list(
         card2rank,

R/weave-coverage.R → R/weave_coverage.R

@@ -30,7 +30,7 @@
 #' result
 #'
 #' # Now let's spike a hand
-#' cheat <- draw_cards()[c(1, 10, 11, 12, 13)]
+#' cheat <- draw_cards()[c(10, 11, 12, 13, 1)]
 #' cheat
 #'
 #' .path = c("card", "rank", "straight")
@@ -186,12 +186,15 @@ weave_coverage <- function(
 
     # Ensure LinkMap order
     shared2from <- as.matrix(seen, terms = c(shared, from))
-    shared2to <- as.matrix(full, terms = c(shared, to))
+    shared2to   <- as.matrix(full, terms = c(shared, to))
 
-    if( length(.data) ) { shared2from <- shared2from[, .data] }
+    if( length(.data) ) {
+        shared2from[, !colnames(shared2from) %in% .data] <- FALSE
+        }
     # Link observed features to sets
     res <- Matrix::crossprod( shared2to, shared2from != 0L )
     res <- Matrix::t(Matrix::Matrix( res, sparse = TRUE ))
+
     obs_set <- Matrix::colSums(res)
 
     tot_set <- pmax(Matrix::colSums(shared2to), 1L)