1library("matrixStats") 2 3rowProds_R <- function(x, FUN = prod, na.rm = FALSE, ..., useNames = NA) { 4 res <- apply(x, MARGIN = 1L, FUN = FUN, na.rm = na.rm) 5 if (is.na(useNames) || !useNames) names(res) <- NULL 6 res 7} 8 9all.equal.na <- function(target, current, ...) { 10 # Computations involving NaN may return NaN or NA, cf. ?is.nan 11 current[is.nan(current)] <- NA_real_ 12 target[is.nan(target)] <- NA_real_ 13 all.equal(target, current, ...) 14} 15 16for (mode in c("integer", "double")) { 17 # Missing values 18 x <- matrix(c(1, NA, NaN, 1, 1, 0, 1, 0), nrow = 4, ncol = 2) 19 cat("mode: ", mode, "\n", sep = "") 20 storage.mode(x) <- mode 21 str(x) 22 23 # To check names attribute 24 dimnames <- list(letters[1:4], LETTERS[1:2]) 25 26 # Test with and without dimnames on x 27 for (setDimnames in c(TRUE, FALSE)) { 28 if (setDimnames) dimnames(x) <- dimnames 29 else dimnames(x) <- NULL 30 # Check names attribute 31 for (useNames in c(NA, TRUE, FALSE)) { 32 y0 <- rowProds_R(x, na.rm = TRUE, useNames = useNames) 33 print(y0) 34 y1 <- rowProds(x, na.rm = TRUE, useNames = useNames) 35 print(y1) 36 y2 <- colProds(t(x), na.rm = TRUE, useNames = useNames) 37 print(y2) 38 stopifnot(all.equal(y1, y0)) 39 stopifnot(all.equal(y2, y1)) 40 41 # Missing values 42 y0 <- rowProds_R(x, na.rm = FALSE, useNames = useNames) 43 print(y0) 44 y1 <- rowProds(x, na.rm = FALSE, useNames = useNames) 45 print(y1) 46 y2 <- colProds(t(x), na.rm = FALSE, useNames = useNames) 47 print(y2) 48 stopifnot(all.equal(y1, y0)) 49 stopifnot(all.equal(y2, y1)) 50 51 # "Empty" rows 52 y0 <- rowProds_R(x[integer(0), , drop = FALSE], na.rm = FALSE, useNames = useNames) 53 print(y0) 54 y1 <- rowProds(x[integer(0), , drop = FALSE], na.rm = FALSE, useNames = useNames) 55 print(y1) 56 y2 <- colProds(t(x[integer(0), , drop = FALSE]), na.rm = FALSE, useNames = useNames) 57 print(y2) 58 stopifnot(all.equal.na(y1, y0)) 59 stopifnot(all.equal(y2, y1)) 60 stopifnot(length(y1) == 0L) 61 62 # Using product() 63 y1 <- rowProds(x, method = "expSumLog", na.rm = FALSE, useNames = useNames) 64 print(y1) 65 y2 <- colProds(t(x), method = "expSumLog", na.rm = FALSE, useNames = useNames) 66 print(y2) 67 stopifnot(all.equal(y2, y1)) 68 } 69 } 70} # for (mode ...) 71 72 73# Bug report 2012-06-25 74x <- matrix(c(1, 1, 1, 1, 1, 0, 1, 0), nrow = 4, ncol = 2) 75y0 <- rowProds_R(x) 76print(y0) 77y1 <- rowProds(x) 78print(y1) 79y2 <- colProds(t(x)) 80print(y2) 81stopifnot(all.equal.na(y1, y0)) 82stopifnot(all.equal.na(y1, x[, 1] * x[, 2])) 83stopifnot(all.equal.na(y2, y1)) 84# Check names attribute 85dimnames(x) <- dimnames 86y0 <- rowProds_R(x, useNames = TRUE) 87print(y0) 88y1 <- rowProds(x, useNames = TRUE) 89print(y1) 90y2 <- colProds(t(x), useNames = TRUE) 91print(y2) 92stopifnot(all.equal.na(y1, y0)) 93stopifnot(all.equal.na(y1, x[, 1] * x[, 2])) 94stopifnot(all.equal.na(y2, y1)) 95 96# Bug report 2014-03-25 ("all rows contains a zero") 97x <- matrix(c(0, 1, 1, 0), nrow = 2, ncol = 2) 98# To check names attribute 99dimnames <- list(letters[1:2], LETTERS[1:2]) 100y0 <- rowProds_R(x) 101print(y0) 102y1 <- rowProds(x) 103print(y1) 104y2 <- colProds(t(x)) 105print(y2) 106stopifnot(all.equal.na(y1, y0)) 107stopifnot(all.equal.na(y1, c(0, 0))) 108stopifnot(all.equal.na(y2, y1)) 109# Check names attribute 110dimnames(x) <- dimnames 111y0 <- rowProds_R(x, useNames = TRUE) 112print(y0) 113y1 <- rowProds(x, useNames = TRUE) 114print(y1) 115y2 <- colProds(t(x), useNames = TRUE) 116print(y2) 117stopifnot(all.equal.na(y1, y0)) 118stopifnot(all.equal.na(y2, y1)) 119