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