From d37513074c5101300f69fc837d7855d95894734a Mon Sep 17 00:00:00 2001 From: thomaz Date: Sat, 25 Jul 2026 23:41:28 +0200 Subject: [PATCH] fix coverage vignette --- NAMESPACE | 2 ++ R/AllClasses.R | 10 +++++----- R/MultiFactor-methods.R | 4 ++-- R/as.LinkMap.R | 8 ++++---- R/levels-utils.R | 7 ++----- R/playing_cards.R | 18 ++++++++++++++---- R/{weave-coverage.R => weave_coverage.R} | 9 ++++++--- man/weave_coverage.Rd | 4 ++-- 8 files changed, 37 insertions(+), 25 deletions(-) rename R/{weave-coverage.R => weave_coverage.R} (97%) diff --git a/NAMESPACE b/NAMESPACE index db46495..0084217 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/AllClasses.R b/R/AllClasses.R index 90e4e10..3c50508 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -25,6 +25,7 @@ #' LinkMap(x) #' #' @seealso [MultiFactor()] +#' @importFrom forcats as_factor #' @export #' LinkMap <- S7::new_class( @@ -47,14 +48,13 @@ 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( @@ -62,8 +62,8 @@ LinkMap <- S7::new_class( 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) diff --git a/R/MultiFactor-methods.R b/R/MultiFactor-methods.R index 353f808..0dc7a49 100644 --- a/R/MultiFactor-methods.R +++ b/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 diff --git a/R/as.LinkMap.R b/R/as.LinkMap.R index 9ad445c..f76797b 100644 --- a/R/as.LinkMap.R +++ b/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 diff --git a/R/levels-utils.R b/R/levels-utils.R index 2e9dc86..8f1a7ff 100644 --- a/R/levels-utils.R +++ b/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) } diff --git a/R/playing_cards.R b/R/playing_cards.R index 65f30de..6c70d67 100644 --- a/R/playing_cards.R +++ b/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, diff --git a/R/weave-coverage.R b/R/weave_coverage.R similarity index 97% rename from R/weave-coverage.R rename to R/weave_coverage.R index a3a855d..9a5309d 100644 --- a/R/weave-coverage.R +++ b/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) diff --git a/man/weave_coverage.Rd b/man/weave_coverage.Rd index 145273c..9af1655 100644 --- a/man/weave_coverage.Rd +++ b/man/weave_coverage.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/weave-coverage.R +% Please edit documentation in R/weave_coverage.R \name{weave_coverage} \alias{weave_coverage} \title{Perform enrichtment analysis from a weave} @@ -55,7 +55,7 @@ result <- weave_coverage( 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")