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