From b1725f05d17ac0d4c5bb44cc079bc454d96c3aa5 Mon Sep 17 00:00:00 2001 From: yun Date: Sat, 6 Jul 2024 16:46:13 +0800 Subject: [PATCH] apply: add names for each row/col --- R/Method-apply.R | 16 ++++++++++------ tests/testthat/setup.R | 27 +++++++++++++++++++++++++-- 2 files changed, 35 insertions(+), 8 deletions(-) diff --git a/R/Method-apply.R b/R/Method-apply.R index 06f8317..170b649 100644 --- a/R/Method-apply.R +++ b/R/Method-apply.R @@ -37,9 +37,9 @@ methods::setMethod( } seed <- to_BPCells(X@seed) values <- integer(dim(seed)[3L - MARGIN]) # nolint - nms <- switch(MARGIN, - rownames(seed), - colnames(seed) + names(values) <- switch(MARGIN, + colnames(seed), + rownames(seed) ) .fun <- switch(MARGIN, function(.value, .row_index, .col_index, ...) { @@ -67,20 +67,24 @@ methods::setMethod( BPCells::apply_by_col(mat = seed, fun = .fun, ...) } ) + ans_nms <- switch(MARGIN, + rownames(seed), + colnames(seed) + ) if (simplify) { lens <- lengths(ans) if (all(lens == .subset(lens, 1L))) { if (.subset(lens, 1L) == 1L) { ans <- unlist(ans, recursive = FALSE, use.names = FALSE) - names(ans) <- nms + names(ans) <- ans_nms } else { ans <- do.call(cbind, ans) - colnames(ans) <- nms + colnames(ans) <- ans_nms } return(ans) } } - names(ans) <- nms + names(ans) <- ans_nms ans } ) diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 8abc74b..f96f890 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -10,6 +10,23 @@ test_methods <- function( mat <- mat %||% as.matrix(obj) mat <- convert_mode(mat, mode) + ######################################################## + cli::cli_inform("{.field as} for seed {name} works as expected") + testthat::test_that( + sprintf("`as()` for seed %s works as expected", name), + { + obj <- BPCellsMatrix(obj) + testthat::expect_s4_class( + methods::as(obj, "IterableMatrix"), + "IterableMatrix" + ) + testthat::expect_identical( + methods::as(obj, "IterableMatrix"), + to_BPCells(obj@seed) + ) + } + ) + ######################################################## cli::cli_inform("{.field convert_mode} for seed {name} works as expected") testthat::test_that( @@ -522,6 +539,10 @@ test_methods <- function( apply(obj, 1, stats::quantile), apply(mat, 1, stats::quantile) ) + testthat::expect_equal( + apply(obj, 1, function(x) x[x > 0L]), + apply(mat, 1, function(x) x[x > 0L]) + ) testthat::expect_equal( apply(obj, 1, stats::quantile, simplify = FALSE), apply(mat, 1, stats::quantile, simplify = FALSE) @@ -539,18 +560,20 @@ test_methods <- function( apply(mat, 2L, sum) ) - testthat::expect_equal(apply(obj, 2L, mean), apply(mat, 2L, mean)) testthat::expect_equal( apply(transpose_axis(obj), 2L, mean), apply(mat, 2L, mean) ) - testthat::expect_equal( apply(obj, 2L, stats::quantile), apply(mat, 2L, stats::quantile) ) + testthat::expect_equal( + apply(obj, 2L, function(x) x[x > 0L]), + apply(mat, 2L, function(x) x[x > 0L]) + ) testthat::expect_equal( apply(obj, 2L, stats::quantile, simplify = FALSE), apply(mat, 2L, stats::quantile, simplify = FALSE)