1library("matrixStats")
2
3validateIndicesTestVector <- function(x, idxs, ftest, fsure,
4                                      debug = FALSE, ...) {
5  if (debug) cat(sprintf("idxs=%s, type=%s\n",
6                         toString(idxs), toString(typeof(idxs))))
7
8  suppressWarnings({
9    actual <- tryCatch(ftest(x, idxs = idxs, ...), error = function(c) "error")
10    expect <- tryCatch({
11      if (!is.null(idxs)) x <- x[idxs]
12      fsure(x, ...)
13    }, error = function(c) "error")
14  })
15  if (debug) cat(sprintf("actual=%s\nexpect=%s\n",
16                         toString(actual), toString(expect)))
17
18  stopifnot(all.equal(actual, expect))
19}
20
21validateIndicesTestVector_w <- function(x, w, idxs, ftest, fsure,
22                                        debug = FALSE, ...) {
23  if (debug) cat(sprintf("idxs=%s, type=%s\n",
24                         toString(idxs), toString(typeof(idxs))))
25
26  suppressWarnings({
27    actual <- tryCatch(ftest(x, w, idxs = idxs, ...),
28                       error = function(c) "error")
29    expect <- tryCatch({
30      if (!is.null(idxs)) {
31        x <- x[idxs]
32        w <- w[idxs]
33      }
34      fsure(x, w, ...)
35    }, error = function(c) "error")
36  })
37  if (debug) cat(sprintf("actual=%s\nexpect=%s\n",
38                         toString(actual), toString(expect)))
39
40  stopifnot(all.equal(actual, expect))
41}
42
43validateIndicesTestMatrix <- function(x, rows, cols, ftest, fcoltest, fsure,
44                                      debug = FALSE, ...) {
45  if (debug) {
46    cat(sprintf("rows=%s; type=%s\n", toString(rows), toString(typeof(rows))))
47    cat(sprintf("cols=%s; type=%s\n", toString(cols), toString(typeof(cols))))
48  }
49
50  suppressWarnings({
51    if (missing(fcoltest)) {
52      actual <- tryCatch(ftest(x, rows = rows, cols = cols, ...),
53                         error = function(c) "error")
54    } else {
55      actual <- tryCatch(fcoltest(t(x), rows = cols, cols = rows, ...),
56                         error = function(c) "error")
57    }
58
59    expect <- tryCatch({
60      if (!is.null(rows) && !is.null(cols)) {
61        x <- x[rows, cols, drop = FALSE]
62      } else if (!is.null(rows)) {
63        x <- x[rows, , drop = FALSE]
64      } else if (!is.null(cols)) {
65        x <- x[, cols, drop = FALSE]
66      }
67      fsure(x, ...)
68    }, error = function(c) "error")
69  })
70  if (debug) cat(sprintf("actual=%s\nexpect=%s\n",
71                         toString(actual), toString(expect)))
72
73  stopifnot(all.equal(actual, expect))
74}
75
76validateIndicesTestMatrix_w <- function(x, w, rows, cols, ftest,
77                                        fcoltest, fsure, debug = FALSE, ...) {
78  if (debug) {
79    cat(sprintf("rows=%s; type=%s\n", toString(rows), toString(typeof(rows))))
80    cat(sprintf("cols=%s; type=%s\n", toString(cols), toString(typeof(cols))))
81  }
82
83  suppressWarnings({
84    if (missing(fcoltest)) {
85      actual <- tryCatch(ftest(x, w, rows = rows, cols = cols, ...),
86                         error = function(c) "error")
87    } else {
88      actual <- tryCatch(fcoltest(t(x), w, rows = cols, cols = rows, ...),
89                         error = function(c) "error")
90    }
91
92    expect <- tryCatch({
93      if (!is.null(rows) && !is.null(cols)) {
94        x <- x[rows, cols, drop = FALSE]
95        w <- w[cols]
96      } else if (!is.null(rows)) {
97        x <- x[rows, , drop = FALSE]
98      } else if (!is.null(cols)) {
99        x <- x[, cols, drop = FALSE]
100        w <- w[cols]
101      }
102      fsure(x, w, ...)
103    }, error = function(c) "error")
104  })
105  if (debug) cat(sprintf("actual=%s\nexpect=%s\n",
106                         toString(actual), toString(expect)))
107
108  stopifnot(all.equal(actual, expect))
109}
110
111index_cases <- list()
112# negative indices with duplicates
113index_cases[[length(index_cases) + 1]] <- c(-4, 0, 0, -3, -1, -3, -1)
114
115# positive indices
116index_cases[[length(index_cases) + 1]] <- c(3, 5, 1)
117
118# positive indices with duplicates
119index_cases[[length(index_cases) + 1]] <- c(3, 0, 0, 5, 1, 5, 5)
120
121# positive indices out of ranges
122index_cases[[length(index_cases) + 1]] <- 4:9
123
124# negative out of ranges: just ignore
125index_cases[[length(index_cases) + 1]] <- c(-5, 0, -3, -1, -9)
126
127# negative indices exclude all
128index_cases[[length(index_cases) + 1]] <- -1:-6
129
130# idxs is single number
131index_cases[[length(index_cases) + 1]] <- 4
132index_cases[[length(index_cases) + 1]] <- -4
133index_cases[[length(index_cases) + 1]] <- 0
134
135# idxs is empty
136index_cases[[length(index_cases) + 1]] <- integer()
137
138# NA in idxs
139index_cases[[length(index_cases) + 1]] <- c(NA_real_, 0, 2)
140
141# Inf in idxs
142index_cases[[length(index_cases) + 1]] <- c(-Inf, -1)
143index_cases[[length(index_cases) + 1]] <- c(NA_real_, 0, 2, Inf)
144
145# single logical
146index_cases[[length(index_cases) + 1]] <- NA
147index_cases[[length(index_cases) + 1]] <- TRUE
148index_cases[[length(index_cases) + 1]] <- FALSE
149
150# full logical idxs
151index_cases[[length(index_cases) + 1]] <- c(FALSE, TRUE, FALSE, TRUE,
152                                           TRUE, FALSE)
153
154# too many logical idxs
155index_cases[[length(index_cases) + 1]] <- c(FALSE, TRUE, FALSE, TRUE,
156                                        TRUE, TRUE, FALSE, TRUE)
157
158# insufficient idxs
159index_cases[[length(index_cases) + 1]] <- c(FALSE, TRUE)
160index_cases[[length(index_cases) + 1]] <- c(FALSE, TRUE, NA)
161index_cases[[length(index_cases) + 1]] <- c(FALSE, TRUE, NA, FALSE)
162
163# NULL
164index_cases[length(index_cases) + 1] <- list(NULL)
165
166
167index_error_cases <- list()
168# mixed positive and negative indices
169index_error_cases[[length(index_cases) + 1]] <- 1:-1
170
171# mixed positive, negative and zero indices
172index_error_cases[[length(index_cases) + 1]] <- c(-4, 0, 0, 1)
173
174# NA in idxs
175index_error_cases[[length(index_cases) + 1]] <- c(NA_real_, -2)
176