Last updated on 2019-11-26 00:52:15 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 0.1.0 | 2.52 | 26.79 | 29.31 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 0.1.0 | 2.23 | 21.68 | 23.91 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 0.1.0 | 63.81 | OK | |||
| r-devel-linux-x86_64-fedora-gcc | 0.1.0 | 62.21 | OK | |||
| r-devel-windows-ix86+x86_64 | 0.1.0 | 8.00 | 67.00 | 75.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 0.1.0 | 10.00 | 49.00 | 59.00 | OK | |
| r-patched-linux-x86_64 | 0.1.0 | 2.39 | 50.77 | 53.16 | OK | |
| r-patched-solaris-x86 | 0.1.0 | 71.90 | OK | |||
| r-release-linux-x86_64 | 0.1.0 | 2.67 | 50.65 | 53.32 | OK | |
| r-release-windows-ix86+x86_64 | 0.1.0 | 7.00 | 48.00 | 55.00 | OK | |
| r-release-osx-x86_64 | 0.1.0 | OK | ||||
| r-oldrel-windows-ix86+x86_64 | 0.1.0 | 3.00 | 71.00 | 74.00 | OK | |
| r-oldrel-osx-x86_64 | 0.1.0 | OK |
Version: 0.1.0
Check: examples
Result: ERROR
Running examples in 'TaxicabCA-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: CombineCollinearRowsCols
> ### Title: Removes rows and columns of zeros and optionnally, row or column
> ### duplicates
> ### Aliases: CombineCollinearRowsCols
>
> ### ** Examples
>
> CombineCollinearRowsCols(matrix(1:3,nrow=3,ncol=2),cols=TRUE)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
TaxicabCA
--- call from context ---
CombineCollinearRowsCols(matrix(1:3, nrow = 3, ncol = 2), cols = TRUE)
--- call from argument ---
if (class(Y) != "matrix") return(NULL)
--- R stacktrace ---
where 1: CombineCollinearRowsCols(matrix(1:3, nrow = 3, ncol = 2), cols = TRUE)
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (Y, rows = F, cols = F)
{
try(Y <- as.matrix(Y))
if (class(Y) != "matrix")
return(NULL)
if (sum(abs(Y)) == 0)
return(matrix(NA, nrow = 0, ncol = 0))
if (!cols & nrow(Y) == 1)
return(sum(Y))
if (!rows & ncol(Y) == 1)
return(sum(Y))
Y <- Y[apply(abs(Y), 1, sum) != 0, , drop = F]
if (ncol(Y) > 1)
Y <- Y[, apply(abs(Y), 2, sum) != 0, drop = F]
if (rows == F & cols == F)
return(Y)
if ((rows == F & cols == T)) {
Y <- t(CombineCollinearRowsCols(t(Y), rows = T, cols = F))
return(Y)
}
if ((rows == T & cols == T)) {
Y <- CombineCollinearRowsCols(Y, rows = T)
Y <- t(CombineCollinearRowsCols(t(Y), rows = T))
return(Y)
}
ExtractColinearRowsBasis <- function(Y, indexCol = 1) {
OK <- sum(Y[, indexCol]) != 0
while ((!OK) & indexCol < ncol(Y)) {
indexCol <- indexCol + 1
OK <- sum(Y[, indexCol] != 0)
}
keep <- which(Y[, indexCol] != 0)
Y.Remainer <- Y[-keep, , drop = F]
Y.Kept <- Y[keep, , drop = F]
Y.Kept <- (1/Y.Kept[, indexCol]) * Y.Kept
M <- unique(Y.Kept[(duplicated(Y.Kept, MARGIN = 1)),
, drop = F], MARGIN = 1)
if (nrow(Y.Remainer) > 0 & indexCol < ncol(Y)) {
M1 <- ExtractColinearRowsBasis(Y.Remainer, indexCol = indexCol +
1)
M <- rbind(M, M1)
}
return(M)
}
CheckVectorCollinearity <- function(V, W) {
keep <- !(V == 0 & W == 0)
V <- V[keep]
W <- W[keep]
if (length(V) != length(W) | sum(is.na(V)) > 0 | sum(is.na(W)) >
0)
return(NULL)
return(length(unique(round(V/W, 10))) == 1)
}
Basis <- ExtractColinearRowsBasis(Y)
if (nrow(Basis) == 0)
return(Y)
rowsToRemove <- c()
ii <- 1
rowsCombined <- list()
for (ii in 1:nrow(Basis)) {
rowsKept <- which(apply(Y, 1, CheckVectorCollinearity,
W = Basis[ii, ]))
rowsCombined <- c(rowsCombined, list(names(rowsKept)))
names(rowsCombined)[length(rowsCombined)] <- names(rowsKept)[1]
Y[rowsKept[1], ] <- apply(Y[rowsKept, , drop = F], 2,
sum)
if (!is.null(rownames(Y)))
rownames(Y)[rowsKept[1]] <- paste(names(rowsKept),
collapse = "+")
rowsToRemove <- c(rowsToRemove, rowsKept[-1])
}
if (length(rowsCombined) > 0) {
print("Rows/columns combined")
print(rowsCombined)
}
return(Y[-rowsToRemove, ])
}
<bytecode: 0x1def3f0>
<environment: namespace:TaxicabCA>
--- function search by body ---
Function CombineCollinearRowsCols in namespace TaxicabCA has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
Flavor: r-devel-linux-x86_64-debian-clang
Version: 0.1.0
Check: tests
Result: ERROR
Running 'testthat.R' [2s/2s]
Running the tests in 'tests/testthat.R' failed.
Complete output:
> library(testthat)
> library(TaxicabCA)
>
> test_check("TaxicabCA")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
TaxicabCA
--- call from context ---
tca(Data, nAxes = nAxes, algorithm = algorithm)
--- call from argument ---
if (class(Y) != "matrix") {
stop("Input cannot be coerced into a matrix")
return(NULL)
}
--- R stacktrace ---
where 1 at testthat/test.milazzese.cr.r#37: tca(Data, nAxes = nAxes, algorithm = algorithm)
where 2: eval(code, test_env)
where 3: eval(code, test_env)
where 4: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 5: doTryCatch(return(expr), name, parentenv, handler)
where 6: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 7: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 8: doTryCatch(return(expr), name, parentenv, handler)
where 9: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 10: tryCatchList(expr, classes, parentenv, handlers)
where 11: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 12: test_code(NULL, exprs, env)
where 13: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 14: force(code)
where 15: doWithOneRestart(return(expr), restart)
where 16: withOneRestart(expr, restarts[[1L]])
where 17: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 18: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 19: FUN(X[[i]], ...)
where 20: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 21: force(code)
where 22: doWithOneRestart(return(expr), restart)
where 23: withOneRestart(expr, restarts[[1L]])
where 24: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 25: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 26: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 27: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 28: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 29: test_check("TaxicabCA")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (Y, nAxes = 2, dataName = NULL, combineCollinearRows = c(F,
T), combineCollinearCols = c(F, T), algorithm = c("exhaustive",
"criss-cross", "genetic"), returnInputMatrix = c(T, F), verbose = (nAxes >
2), exhaustiveAlgorithmMaxnCol = 20, L1MaxDeltaMax = 10^-10)
{
Y <- try(as.matrix(Y))
if (class(Y) != "matrix") {
stop("Input cannot be coerced into a matrix")
return(NULL)
}
if (min(dim(Y)) < 2) {
stop(paste("Invalid matrix dimensions (", paste(dim(Y),
collapse = "x"), ")", sep = ""))
return(NULL)
}
if (mode(Y) != "numeric") {
stop("Input contains non-numerical values")
return(NULL)
}
if (sum(is.na(Y)) != 0) {
stop("Missing values are not allowed")
return(NULL)
}
if (sum(Y < 0, na.rm = T) != 0) {
stop("Negative values are not allowed")
return(NULL)
}
if (is.null(dataName)) {
yNames <- as.list(match.call())$Y
datetime <- gsub(":", ".", substr(Sys.time(), 1, 16),
fixed = T)
dataName <- paste(yNames)
}
dataName <- dataName[1]
combineCollinearRows <- combineCollinearRows[1]
combineCollinearCols <- combineCollinearCols[1]
rowColCombined <- NULL
returnInputMatrix <- returnInputMatrix[1]
if (!(combineCollinearRows %in% c(T, F)))
cat("\n Invalid 'combineCollinearRows' value")
if (!(combineCollinearCols %in% c(T, F)))
cat("\n Invalid 'combineCollinearCols' value")
if (!(returnInputMatrix %in% c(T, F)))
cat("\n Invalid 'returnInputMatrix' value")
if (!(combineCollinearCols %in% c(T, F)))
cat("\n Invalid 'combineCollinearCols' value")
nRow <- nrow(Y)
nCol <- ncol(Y)
if (is.null(rownames(Y)))
rownames(Y) <- paste("R", substr(10^ceiling(log(10^-10 +
nRow, 10)) + (1:nRow), 2, 1 + ceiling(log(10^-10 +
nRow, 10))), sep = "")
if (is.null(colnames(Y)))
colnames(Y) <- paste("C", substr(10^ceiling(log(10^-10 +
nCol, 10)) + (1:nCol), 2, 1 + ceiling(log(10^-10 +
nCol, 10))), sep = "")
Y <- CombineCollinearRowsCols(Y)
if (combineCollinearRows)
Y <- CombineCollinearRowsCols(Y, rows = T)
if (combineCollinearCols)
Y <- CombineCollinearRowsCols(Y, cols = T)
matrixTransposed <- F
if (nrow(Y) < ncol(Y)) {
matrixTransposed <- T
Y <- t(Y)
}
nRow <- nrow(Y)
nCol <- ncol(Y)
nAxes <- min(c(nAxes, dim(Y) - 1))
algorithm <- algorithm[1]
if (!is.null("algorithm")) {
algorithm <- tolower(substr(algorithm, 1, 2))
if (!(algorithm %in% c("ex", "ge", "cr"))) {
algorithm <- NULL
}
if (algorithm == "ex" & nCol > exhaustiveAlgorithmMaxnCol) {
algorithm <- "cr"
}
}
if (is.null(algorithm)) {
if (nCol <= exhaustiveAlgorithmMaxnCol) {
algorithm <- "ex"
}
else {
algorithm <- "cr"
}
}
if (algorithm == "ge" & !("GA" %in% installed.packages())) {
algorithm <- "cr"
warning("Package GA not found. Defaulting to criss-cross algorithm.")
}
if (algorithm == "ge") {
cat("The genetic algorithm option is experimental. Convergence of the genetic algorithm is not garanteed. \n\n")
}
axesNames <- paste("Axis", substr(10^ceiling(log(10^-10 +
nAxes, 10)) + (1:nAxes), 2, 1 + ceiling(log(10^-10 +
nAxes, 10))), sep = "")
Toti <- matrix(rowSums(Y), ncol = 1)
TOT <- colSums(Toti)
rownames(Toti) <- rownames(Y)
Totj <- matrix(colSums(Y), nrow = 1)
colnames(Toti) <- rownames(Totj) <- "MASS"
colnames(Totj) <- colnames(Y)
Ti <- Toti/TOT
Tj <- Totj/TOT
pResidual <- (Y - (matrix(rowSums(Y), ncol = 1) %*% (matrix(colSums(Y),
nrow = 1))/TOT))/TOT
A <- matrix(0, nrow = nRow, ncol = nAxes)
rownames(A) <- rownames(Y)
B <- matrix(0, ncol = nCol, nrow = nAxes)
colnames(B) <- colnames(Y)
lambda <- rep(NaN, nAxes)
names(lambda) <- axesNames
colnames(A) <- rownames(B) <- axesNames
t0 <- Sys.time()
t1 <- Sys.time()
difftime(t1, t0, units = "secs")
memoryUsed <- 2^(nCol - 1) * nCol * 4
memoryUsed/(2^20)
if (algorithm == "ex") {
algorithmUsed <- "Exhaustive"
SearchFunction <- SearchExhaustive
}
else if (algorithm == "ge") {
if (requireNamespace("GA", quietly = T)) {
algorithmUsed <- "Genetic"
SearchFunction <- SearchGeneticAlgoritm
}
else {
algorithm <- "cr"
algorithmUsed <- "Criss-cross"
SearchFunction <- SearchCrissCross
}
}
else if (algorithm == "cr") {
algorithmUsed <- "Criss-cross"
SearchFunction <- SearchCrissCross
}
else {
return(NULL)
}
iiAxis <- 1
for (iiAxis in 1:nAxes) {
if (verbose)
cat(paste("Computing axis no", iiAxis, "\n"))
axisRes <- SearchFunction(pResidual)
lambda[iiAxis] <- axisRes$L1Max
A[, iiAxis] <- pResidual %*% t(axisRes$uMax)
v <- sign(A[, iiAxis, drop = F])
B[iiAxis, ] <- t(v) %*% pResidual
pResidual <- pResidual - A[, iiAxis, drop = F] %*% (B[iiAxis,
, drop = F]/lambda[iiAxis])
}
FF <- A/as.vector(Ti)
GG <- t(B * matrix(1/Tj, nrow = nAxes, ncol = nCol, byrow = T))
if (matrixTransposed) {
A. <- A
A <- t(B)
B <- t(A.)
rm(A.)
FF. <- FF
FF <- t(GG)
GG <- t(FF.)
rm(FF.)
u <- sign(FF)
}
v <- sign(GG)
u <- sign(FF)
rowScores <- as.vector(1/Ti) * A
colScores <- B/as.vector(Tj)
rowScores <- A/as.vector(Ti)
colScores <- B * matrix(1/Tj, nrow = nAxes, ncol = nCol,
byrow = T)
if (F) {
Max <- max(c(range(abs(rowScores[, 1:2])), range(abs(colScores[1:2,
]))))
plot(rowScores[, 1], rowScores[, 2], col = "red", xlim = c(-Max,
Max), ylim = c(-Max, Max), type = "n")
text(rowScores[1, ], rowScores[2, ], rownames(Y), col = "red")
text(colScores[, 1], colScores[, 2], colnames(Y), col = "blue")
}
if (!returnInputMatrix)
Y <- NA
L <- list(dispersion = lambda, rowScores = rowScores, colScores = colScores,
rowMass = Ti, colMass = Tj, nAxes = nAxes, dataName = dataName,
algorithm = algorithmUsed, dataMatrixTotal = TOT, dataMatrix = Y,
rowColCombined = NULL)
class(L) <- c(class(L), "tca")
return(L)
}
<bytecode: 0x3775f88>
<environment: namespace:TaxicabCA>
--- function search by body ---
Function tca in namespace TaxicabCA has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
Flavor: r-devel-linux-x86_64-debian-clang
Version: 0.1.0
Check: examples
Result: ERROR
Running examples in ‘TaxicabCA-Ex.R’ failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: CombineCollinearRowsCols
> ### Title: Removes rows and columns of zeros and optionnally, row or column
> ### duplicates
> ### Aliases: CombineCollinearRowsCols
>
> ### ** Examples
>
> CombineCollinearRowsCols(matrix(1:3,nrow=3,ncol=2),cols=TRUE)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
TaxicabCA
--- call from context ---
CombineCollinearRowsCols(matrix(1:3, nrow = 3, ncol = 2), cols = TRUE)
--- call from argument ---
if (class(Y) != "matrix") return(NULL)
--- R stacktrace ---
where 1: CombineCollinearRowsCols(matrix(1:3, nrow = 3, ncol = 2), cols = TRUE)
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (Y, rows = F, cols = F)
{
try(Y <- as.matrix(Y))
if (class(Y) != "matrix")
return(NULL)
if (sum(abs(Y)) == 0)
return(matrix(NA, nrow = 0, ncol = 0))
if (!cols & nrow(Y) == 1)
return(sum(Y))
if (!rows & ncol(Y) == 1)
return(sum(Y))
Y <- Y[apply(abs(Y), 1, sum) != 0, , drop = F]
if (ncol(Y) > 1)
Y <- Y[, apply(abs(Y), 2, sum) != 0, drop = F]
if (rows == F & cols == F)
return(Y)
if ((rows == F & cols == T)) {
Y <- t(CombineCollinearRowsCols(t(Y), rows = T, cols = F))
return(Y)
}
if ((rows == T & cols == T)) {
Y <- CombineCollinearRowsCols(Y, rows = T)
Y <- t(CombineCollinearRowsCols(t(Y), rows = T))
return(Y)
}
ExtractColinearRowsBasis <- function(Y, indexCol = 1) {
OK <- sum(Y[, indexCol]) != 0
while ((!OK) & indexCol < ncol(Y)) {
indexCol <- indexCol + 1
OK <- sum(Y[, indexCol] != 0)
}
keep <- which(Y[, indexCol] != 0)
Y.Remainer <- Y[-keep, , drop = F]
Y.Kept <- Y[keep, , drop = F]
Y.Kept <- (1/Y.Kept[, indexCol]) * Y.Kept
M <- unique(Y.Kept[(duplicated(Y.Kept, MARGIN = 1)),
, drop = F], MARGIN = 1)
if (nrow(Y.Remainer) > 0 & indexCol < ncol(Y)) {
M1 <- ExtractColinearRowsBasis(Y.Remainer, indexCol = indexCol +
1)
M <- rbind(M, M1)
}
return(M)
}
CheckVectorCollinearity <- function(V, W) {
keep <- !(V == 0 & W == 0)
V <- V[keep]
W <- W[keep]
if (length(V) != length(W) | sum(is.na(V)) > 0 | sum(is.na(W)) >
0)
return(NULL)
return(length(unique(round(V/W, 10))) == 1)
}
Basis <- ExtractColinearRowsBasis(Y)
if (nrow(Basis) == 0)
return(Y)
rowsToRemove <- c()
ii <- 1
rowsCombined <- list()
for (ii in 1:nrow(Basis)) {
rowsKept <- which(apply(Y, 1, CheckVectorCollinearity,
W = Basis[ii, ]))
rowsCombined <- c(rowsCombined, list(names(rowsKept)))
names(rowsCombined)[length(rowsCombined)] <- names(rowsKept)[1]
Y[rowsKept[1], ] <- apply(Y[rowsKept, , drop = F], 2,
sum)
if (!is.null(rownames(Y)))
rownames(Y)[rowsKept[1]] <- paste(names(rowsKept),
collapse = "+")
rowsToRemove <- c(rowsToRemove, rowsKept[-1])
}
if (length(rowsCombined) > 0) {
print("Rows/columns combined")
print(rowsCombined)
}
return(Y[-rowsToRemove, ])
}
<bytecode: 0x5594e8eb3380>
<environment: namespace:TaxicabCA>
--- function search by body ---
Function CombineCollinearRowsCols in namespace TaxicabCA has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 0.1.0
Check: tests
Result: ERROR
Running ‘testthat.R’ [2s/4s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(TaxicabCA)
>
> test_check("TaxicabCA")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
TaxicabCA
--- call from context ---
tca(Data, nAxes = nAxes, algorithm = algorithm)
--- call from argument ---
if (class(Y) != "matrix") {
stop("Input cannot be coerced into a matrix")
return(NULL)
}
--- R stacktrace ---
where 1 at testthat/test.milazzese.cr.r#37: tca(Data, nAxes = nAxes, algorithm = algorithm)
where 2: eval(code, test_env)
where 3: eval(code, test_env)
where 4: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 5: doTryCatch(return(expr), name, parentenv, handler)
where 6: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 7: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 8: doTryCatch(return(expr), name, parentenv, handler)
where 9: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 10: tryCatchList(expr, classes, parentenv, handlers)
where 11: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 12: test_code(NULL, exprs, env)
where 13: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 14: force(code)
where 15: doWithOneRestart(return(expr), restart)
where 16: withOneRestart(expr, restarts[[1L]])
where 17: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 18: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 19: FUN(X[[i]], ...)
where 20: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 21: force(code)
where 22: doWithOneRestart(return(expr), restart)
where 23: withOneRestart(expr, restarts[[1L]])
where 24: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 25: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 26: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 27: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 28: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 29: test_check("TaxicabCA")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (Y, nAxes = 2, dataName = NULL, combineCollinearRows = c(F,
T), combineCollinearCols = c(F, T), algorithm = c("exhaustive",
"criss-cross", "genetic"), returnInputMatrix = c(T, F), verbose = (nAxes >
2), exhaustiveAlgorithmMaxnCol = 20, L1MaxDeltaMax = 10^-10)
{
Y <- try(as.matrix(Y))
if (class(Y) != "matrix") {
stop("Input cannot be coerced into a matrix")
return(NULL)
}
if (min(dim(Y)) < 2) {
stop(paste("Invalid matrix dimensions (", paste(dim(Y),
collapse = "x"), ")", sep = ""))
return(NULL)
}
if (mode(Y) != "numeric") {
stop("Input contains non-numerical values")
return(NULL)
}
if (sum(is.na(Y)) != 0) {
stop("Missing values are not allowed")
return(NULL)
}
if (sum(Y < 0, na.rm = T) != 0) {
stop("Negative values are not allowed")
return(NULL)
}
if (is.null(dataName)) {
yNames <- as.list(match.call())$Y
datetime <- gsub(":", ".", substr(Sys.time(), 1, 16),
fixed = T)
dataName <- paste(yNames)
}
dataName <- dataName[1]
combineCollinearRows <- combineCollinearRows[1]
combineCollinearCols <- combineCollinearCols[1]
rowColCombined <- NULL
returnInputMatrix <- returnInputMatrix[1]
if (!(combineCollinearRows %in% c(T, F)))
cat("\n Invalid 'combineCollinearRows' value")
if (!(combineCollinearCols %in% c(T, F)))
cat("\n Invalid 'combineCollinearCols' value")
if (!(returnInputMatrix %in% c(T, F)))
cat("\n Invalid 'returnInputMatrix' value")
if (!(combineCollinearCols %in% c(T, F)))
cat("\n Invalid 'combineCollinearCols' value")
nRow <- nrow(Y)
nCol <- ncol(Y)
if (is.null(rownames(Y)))
rownames(Y) <- paste("R", substr(10^ceiling(log(10^-10 +
nRow, 10)) + (1:nRow), 2, 1 + ceiling(log(10^-10 +
nRow, 10))), sep = "")
if (is.null(colnames(Y)))
colnames(Y) <- paste("C", substr(10^ceiling(log(10^-10 +
nCol, 10)) + (1:nCol), 2, 1 + ceiling(log(10^-10 +
nCol, 10))), sep = "")
Y <- CombineCollinearRowsCols(Y)
if (combineCollinearRows)
Y <- CombineCollinearRowsCols(Y, rows = T)
if (combineCollinearCols)
Y <- CombineCollinearRowsCols(Y, cols = T)
matrixTransposed <- F
if (nrow(Y) < ncol(Y)) {
matrixTransposed <- T
Y <- t(Y)
}
nRow <- nrow(Y)
nCol <- ncol(Y)
nAxes <- min(c(nAxes, dim(Y) - 1))
algorithm <- algorithm[1]
if (!is.null("algorithm")) {
algorithm <- tolower(substr(algorithm, 1, 2))
if (!(algorithm %in% c("ex", "ge", "cr"))) {
algorithm <- NULL
}
if (algorithm == "ex" & nCol > exhaustiveAlgorithmMaxnCol) {
algorithm <- "cr"
}
}
if (is.null(algorithm)) {
if (nCol <= exhaustiveAlgorithmMaxnCol) {
algorithm <- "ex"
}
else {
algorithm <- "cr"
}
}
if (algorithm == "ge" & !("GA" %in% installed.packages())) {
algorithm <- "cr"
warning("Package GA not found. Defaulting to criss-cross algorithm.")
}
if (algorithm == "ge") {
cat("The genetic algorithm option is experimental. Convergence of the genetic algorithm is not garanteed. \n\n")
}
axesNames <- paste("Axis", substr(10^ceiling(log(10^-10 +
nAxes, 10)) + (1:nAxes), 2, 1 + ceiling(log(10^-10 +
nAxes, 10))), sep = "")
Toti <- matrix(rowSums(Y), ncol = 1)
TOT <- colSums(Toti)
rownames(Toti) <- rownames(Y)
Totj <- matrix(colSums(Y), nrow = 1)
colnames(Toti) <- rownames(Totj) <- "MASS"
colnames(Totj) <- colnames(Y)
Ti <- Toti/TOT
Tj <- Totj/TOT
pResidual <- (Y - (matrix(rowSums(Y), ncol = 1) %*% (matrix(colSums(Y),
nrow = 1))/TOT))/TOT
A <- matrix(0, nrow = nRow, ncol = nAxes)
rownames(A) <- rownames(Y)
B <- matrix(0, ncol = nCol, nrow = nAxes)
colnames(B) <- colnames(Y)
lambda <- rep(NaN, nAxes)
names(lambda) <- axesNames
colnames(A) <- rownames(B) <- axesNames
t0 <- Sys.time()
t1 <- Sys.time()
difftime(t1, t0, units = "secs")
memoryUsed <- 2^(nCol - 1) * nCol * 4
memoryUsed/(2^20)
if (algorithm == "ex") {
algorithmUsed <- "Exhaustive"
SearchFunction <- SearchExhaustive
}
else if (algorithm == "ge") {
if (requireNamespace("GA", quietly = T)) {
algorithmUsed <- "Genetic"
SearchFunction <- SearchGeneticAlgoritm
}
else {
algorithm <- "cr"
algorithmUsed <- "Criss-cross"
SearchFunction <- SearchCrissCross
}
}
else if (algorithm == "cr") {
algorithmUsed <- "Criss-cross"
SearchFunction <- SearchCrissCross
}
else {
return(NULL)
}
iiAxis <- 1
for (iiAxis in 1:nAxes) {
if (verbose)
cat(paste("Computing axis no", iiAxis, "\n"))
axisRes <- SearchFunction(pResidual)
lambda[iiAxis] <- axisRes$L1Max
A[, iiAxis] <- pResidual %*% t(axisRes$uMax)
v <- sign(A[, iiAxis, drop = F])
B[iiAxis, ] <- t(v) %*% pResidual
pResidual <- pResidual - A[, iiAxis, drop = F] %*% (B[iiAxis,
, drop = F]/lambda[iiAxis])
}
FF <- A/as.vector(Ti)
GG <- t(B * matrix(1/Tj, nrow = nAxes, ncol = nCol, byrow = T))
if (matrixTransposed) {
A. <- A
A <- t(B)
B <- t(A.)
rm(A.)
FF. <- FF
FF <- t(GG)
GG <- t(FF.)
rm(FF.)
u <- sign(FF)
}
v <- sign(GG)
u <- sign(FF)
rowScores <- as.vector(1/Ti) * A
colScores <- B/as.vector(Tj)
rowScores <- A/as.vector(Ti)
colScores <- B * matrix(1/Tj, nrow = nAxes, ncol = nCol,
byrow = T)
if (F) {
Max <- max(c(range(abs(rowScores[, 1:2])), range(abs(colScores[1:2,
]))))
plot(rowScores[, 1], rowScores[, 2], col = "red", xlim = c(-Max,
Max), ylim = c(-Max, Max), type = "n")
text(rowScores[1, ], rowScores[2, ], rownames(Y), col = "red")
text(colScores[, 1], colScores[, 2], colnames(Y), col = "blue")
}
if (!returnInputMatrix)
Y <- NA
L <- list(dispersion = lambda, rowScores = rowScores, colScores = colScores,
rowMass = Ti, colMass = Tj, nAxes = nAxes, dataName = dataName,
algorithm = algorithmUsed, dataMatrixTotal = TOT, dataMatrix = Y,
rowColCombined = NULL)
class(L) <- c(class(L), "tca")
return(L)
}
<bytecode: 0x55b10ec9b190>
<environment: namespace:TaxicabCA>
--- function search by body ---
Function tca in namespace TaxicabCA has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
Flavor: r-devel-linux-x86_64-debian-gcc