1library("matrixStats")
2
3nrow <- 6L
4ncol <- 5L
5data <- matrix(0:4, nrow = nrow, ncol = ncol)
6
7# To check names attribute
8dimnames <- list(letters[1:6], LETTERS[1:5])
9
10modes <- c("integer", "logical", "raw")
11for (mode in modes) {
12  cat(sprintf("Mode: %s...\n", mode))
13
14  x <- data
15  if (mode == "logical") x <- x - 2L
16  if (mode != "raw") x[c(2,5,7)] <- NA_integer_
17  storage.mode(x) <- mode
18  print(x)
19
20  unique_values <- unique(as.vector(x))
21  nbr_of_unique_values <- length(unique_values)
22
23  y <- rowTabulates(x)
24  print(y)
25  stopifnot(
26    identical(dim(y), c(nrow, nbr_of_unique_values)),
27    all(y >= 0)
28  )
29  if (mode != "raw") {
30    y0 <- t(table(x, row(x), useNA = "always")[, seq_len(nrow(x))])
31    stopifnot(all(y == y0))
32  }
33  # Check names attribute
34  dimnames(x) <- dimnames
35  y1 <- rowTabulates(x, useNames = FALSE)
36  y2 <- rowTabulates(x, useNames = NA)
37  stopifnot(all.equal(y1, y))
38  stopifnot(all.equal(y2, y))
39  y <- rowTabulates(x, useNames = TRUE)
40  stopifnot(identical(rownames(y), rownames(x)))
41  dimnames(x) <- NULL
42
43  y <- colTabulates(x)
44  print(y)
45  stopifnot(
46    identical(dim(y), c(ncol, nbr_of_unique_values)),
47    all(y >= 0)
48  )
49  if (mode != "raw") {
50    y0 <- t(table(x, col(x), useNA = "always")[, seq_len(ncol(x))])
51    stopifnot(all(y == y0))
52  }
53  # Check names attribute
54  dimnames(x) <- dimnames
55  y1 <- colTabulates(x, useNames = FALSE)
56  y2 <- colTabulates(x, useNames = NA)
57  stopifnot(all.equal(y1, y))
58  stopifnot(all.equal(y2, y))
59  y <- colTabulates(x, useNames = TRUE)
60  stopifnot(identical(rownames(y), colnames(x)))
61  dimnames(x) <- NULL
62
63  # Count only certain values
64  if (mode == "integer") {
65    subset <- c(0:2, NA_integer_)
66  } else if (mode == "logical") {
67    subset <- c(TRUE, FALSE, NA)
68  } else {
69    subset <- c(0:2)
70  }
71  y <- rowTabulates(x, values = subset)
72  print(y)
73  stopifnot(identical(dim(y), c(nrow, length(subset))))
74  # Check names attribute
75  dimnames(x) <- dimnames
76  y1 <- rowTabulates(x, values = subset, useNames = FALSE)
77  y2 <- rowTabulates(x, values = subset, useNames = NA)
78  stopifnot(all.equal(y1, y))
79  stopifnot(all.equal(y2, y))
80  y <- rowTabulates(x, values = subset, useNames = TRUE)
81  stopifnot(identical(rownames(y), rownames(x)))
82  dimnames(x) <- NULL
83
84  y <- colTabulates(x, values = subset)
85  print(y)
86  stopifnot(identical(dim(y), c(ncol, length(subset))))
87  # Check names attribute
88  dimnames(x) <- dimnames
89  y1 <- colTabulates(x, values = subset, useNames = FALSE)
90  y2 <- colTabulates(x, values = subset, useNames = NA)
91  stopifnot(all.equal(y1, y))
92  stopifnot(all.equal(y2, y))
93  y <- colTabulates(x, values = subset, useNames = TRUE)
94  stopifnot(identical(rownames(y), colnames(x)))
95  dimnames(x) <- NULL
96
97  # Raw
98  if (mode %in% c("integer", "raw")) {
99    subset <- c(0:2)
100
101    y <- rowTabulates(x, values = as.raw(subset))
102    print(y)
103    stopifnot(identical(dim(y), c(nrow, length(subset))))
104    # Check names attribute
105    dimnames(x) <- dimnames
106    y1 <- rowTabulates(x, values = as.raw(subset), useNames = FALSE)
107    y2 <- rowTabulates(x, values = as.raw(subset), useNames = NA)
108    stopifnot(all.equal(y1, y))
109    stopifnot(all.equal(y2, y))
110    y3 <- rowTabulates(x, values = as.raw(subset), useNames = TRUE)
111    stopifnot(identical(rownames(y3), rownames(x)))
112    dimnames(x) <- NULL
113
114    y2 <- colTabulates(t(x), values = as.raw(subset))
115    print(y2)
116    stopifnot(
117      identical(dim(y2), c(nrow, length(subset))),
118      identical(y2, y)
119    )
120    # Check names attribute
121    dimnames(x) <- dimnames
122    y1 <- colTabulates(t(x), values = as.raw(subset), useNames = FALSE)
123    y2 <- colTabulates(t(x), values = as.raw(subset), useNames = NA)
124    stopifnot(all.equal(y1, y))
125    stopifnot(all.equal(y2, y))
126    y <- colTabulates(t(x), values = as.raw(subset), useNames = TRUE)
127    stopifnot(identical(rownames(y), colnames(t(x))))
128    dimnames(x) <- NULL
129  }
130
131  cat(sprintf("Mode: %s...done\n", mode))
132} # for (mode ...)
133