Last updated on 2020-02-19 10:48:57 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 2.0.0 | 2.88 | 33.79 | 36.67 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 2.0.0 | 2.21 | 26.85 | 29.06 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 2.0.0 | 44.73 | ERROR | |||
| r-devel-linux-x86_64-fedora-gcc | 2.0.0 | 43.82 | ERROR | |||
| r-devel-windows-ix86+x86_64 | 2.0.0 | 7.00 | 42.00 | 49.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 2.0.0 | 9.00 | 68.00 | 77.00 | OK | |
| r-patched-linux-x86_64 | 2.0.0 | 2.18 | 28.26 | 30.44 | OK | |
| r-patched-solaris-x86 | 2.0.0 | 58.30 | OK | |||
| r-release-linux-x86_64 | 2.0.0 | 2.18 | 28.15 | 30.33 | OK | |
| r-release-windows-ix86+x86_64 | 2.0.0 | 6.00 | 43.00 | 49.00 | OK | |
| r-release-osx-x86_64 | 2.0.0 | OK | ||||
| r-oldrel-windows-ix86+x86_64 | 2.0.0 | 3.00 | 41.00 | 44.00 | OK | |
| r-oldrel-osx-x86_64 | 2.0.0 | OK |
Version: 2.0.0
Check: tests
Result: ERROR
Running 'testthat.R' [5s/5s]
Running the tests in 'tests/testthat.R' failed.
Complete output:
> library(testthat)
> library(kantorovich)
>
> test_check("kantorovich")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-Pascal.R#61: kantorovich(as.bigq(kernel[i, ]), as.bigq(kernel[j, ]), dist = RHO[[k]])
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-Pascal.R#13: test_that("Pascal", {
library(gmp)
Pascal_Mn <- function(n) {
M <- matrix(0, nrow = n + 1, ncol = n + 2)
for (i in 1:(n + 1)) {
M[i, ][c(i, i + 1)] <- 1
}
return(M)
}
centralKernels <- function(Mn.fun, N) {
L <- Kernels <- vector("list", N)
k <- 0
M <- Mn.fun(k)
m <- nrow(M)
n <- ncol(M)
if (m != 1)
stop("M0 must have only one row")
dims0 <- as.vector(as.bigz(M))
Kernels[[k + 1]] <- matrix(as.character(dims0), dimnames = list(1:n,
1:m))
for (k in 1:N) {
M <- Mn.fun(k)
m <- nrow(M)
n <- ncol(M)
S <- apply(M, 2, function(x) which(x != 0))
dims <- as.vector(dims0 %*% M)
P <- lapply(1:n, function(i) {
as.character(dims0[S[[i]]] * M[S[[i]], i]/dims[i])
})
Kernels[[k + 1]] <- matrix("0", nrow = n, ncol = m,
dimnames = list(1:n, 1:m))
for (i in 1:n) {
Kernels[[k + 1]][i, ][S[[i]]] <- P[[i]]
}
dims0 <- dims
}
return(Kernels)
}
N <- 3
ckernels <- centralKernels(Pascal_Mn, N)
RHO <- lapply(ckernels, function(kernel) matrix("", nrow = nrow(kernel),
ncol = nrow(kernel)))
RHO[[1]] <- (diag(2) + 1)%%2
for (k in 1:N) {
diag(RHO[[k + 1]]) <- "0"
K <- nrow(RHO[[k + 1]])
kernel <- ckernels[[k + 1]]
for (i in 1:(K - 1)) {
for (j in (i + 1):K) {
RHO[[k + 1]][i, j] <- RHO[[k + 1]][j, i] <- as.character(kantorovich(as.bigq(kernel[i,
]), as.bigq(kernel[j, ]), dist = RHO[[k]]))
}
}
}
expect_identical(RHO[[4]], structure(c("0", "1/4", "1/2",
"3/4", "1", "1/4", "0", "1/4", "1/2", "3/4", "1/2", "1/4",
"0", "1/4", "1/2", "3/4", "1/2", "1/4", "0", "1/4", "1",
"3/4", "1/2", "1/4", "0"), .Dim = c(5L, 5L)))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x37b2050>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
-- 1. Error: Pascal (@test-Pascal.R#61) ---------------------------------------
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(...)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu, nu, dist = M)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1 at testthat/test-edistances.R#16: edistances(mu, nu, dist = M)
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(desc, code, env = parent.frame())
where 13 at testthat/test-edistances.R#3: test_that("Main example - numeric", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- edistances(mu, nu)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
rownames(M) <- colnames(M) <- 1:3
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
rownames(M) <- colnames(M) <- c("a", "b", "c")
expect_error(edistances(mu, nu, dist = M))
M <- matrix("1", nrow = 3, ncol = 3)
diag(M) <- "0"
expect_error(edistances(mu, nu, dist = M))
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: 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 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: 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 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: 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 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: 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 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: 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 40: 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 41: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x37b2050>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
-- 2. Error: Main example - numeric (@test-edistances.R#16) -------------------
the condition has length > 1
Backtrace:
1. kantorovich::edistances(mu, nu, dist = M)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu, nu, dist = M)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1 at testthat/test-edistances.R#53: edistances(mu, nu, dist = M)
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(desc, code, env = parent.frame())
where 13 at testthat/test-edistances.R#40: test_that("Main example - bigq", {
mu <- as.bigq(c(1, 2, 4), 7)
nu <- as.bigq(c(1, 1, 1), c(4, 4, 2))
x <- edistances(mu, nu)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], as.bigq(9, 14))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
M <- matrix("1", nrow = 3, ncol = 3)
diag(M) <- "0"
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
M <- as.bigq(M)
expect_error(edistances(mu, nu, dist = M))
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: 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 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: 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 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: 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 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: 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 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: 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 40: 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 41: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x37b2050>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
-- 3. Error: Main example - bigq (@test-edistances.R#53) ----------------------
the condition has length > 1
Backtrace:
1. kantorovich::edistances(mu, nu, dist = M)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-glpk.R#40: kantorovich(mu, nu, dist = D, details = TRUE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-glpk.R#27: test_that("kantorovich_glpk - nonsymmetric dist", {
mu <- c(1, 2, 4)/7
nu <- c(3, 1, 5)/9
D <- matrix(c(c(0, 1, 3), c(1, 0, 4), c(2, 4, 0)), byrow = TRUE,
nrow = 3)
x <- kantorovich_glpk(mu, nu, dist = D)
expect_equal(x, 13/63)
x1 <- kantorovich_glpk(mu, nu, dist = D, solution = TRUE)
x2 <- kantorovich(mu, nu, dist = D, details = TRUE)
expect_true(all.equal(attr(x1, "solution"), attr(x2, "joinings")[[1]],
tolerance = 1e-15, check.attributes = FALSE))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x37b2050>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
-- 4. Error: kantorovich_glpk - nonsymmetric dist (@test-glpk.R#40) -----------
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = D, details = TRUE)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2: kantorovich(mu, nu, dist = M)
where 3: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
where 4: withCallingHandlers({
code
NULL
}, error = function(cnd) {
if (can_entrace(cnd)) {
cnd <- cnd_entrace(cnd)
}
return_from(env, cnd)
})
where 5: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)),
...)
where 6: quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
where 7 at testthat/test-kantorovich.R#23: expect_error(kantorovich(mu, nu, dist = M))
where 8: eval(code, test_env)
where 9: eval(code, test_env)
where 10: 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 11: doTryCatch(return(expr), name, parentenv, handler)
where 12: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 13: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 14: doTryCatch(return(expr), name, parentenv, handler)
where 15: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 16: tryCatchList(expr, classes, parentenv, handlers)
where 17: 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 18: test_code(desc, code, env = parent.frame())
where 19 at testthat/test-kantorovich.R#3: test_that("Main example - numeric mode", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- setNames(nu, c("a", "b", "c"))
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- c(c = 1/2, a = 1/4, b = 1/4)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(c(1/7, 2/7, 4/7), c("a", "b", "c"))
nu <- setNames(c(1/4, 1/4, 1/2), c("a", "b", "c"))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
expect_error(kantorovich(mu, nu, dist = M))
rownames(M) <- colnames(M) <- c("a", "b", "c")
x <- kantorovich(mu, nu, dist = M)
expect_equal(x, 0.107142857142857)
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu, details = TRUE)
bestj <- attr(x, "joinings")
expect_equal(length(bestj), 1)
expect_equal(bestj[[1]], structure(c(0.142857142857143, 0.0357142857142857,
0.0714285714285714, 0, 0.25, 0, 0, 0, 0.5), .Dim = c(3L,
3L), .Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
})
where 20: eval(code, test_env)
where 21: eval(code, test_env)
where 22: 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 23: doTryCatch(return(expr), name, parentenv, handler)
where 24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 25: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 26: doTryCatch(return(expr), name, parentenv, handler)
where 27: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 28: tryCatchList(expr, classes, parentenv, handlers)
where 29: 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 30: test_code(NULL, exprs, env)
where 31: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 32: force(code)
where 33: doWithOneRestart(return(expr), restart)
where 34: withOneRestart(expr, restarts[[1L]])
where 35: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 36: 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 37: FUN(X[[i]], ...)
where 38: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 39: force(code)
where 40: doWithOneRestart(return(expr), restart)
where 41: withOneRestart(expr, restarts[[1L]])
where 42: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 43: 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 44: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 45: 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 46: 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 47: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x37b2050>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-kantorovich.R#26: kantorovich(mu, nu, dist = M)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-kantorovich.R#3: test_that("Main example - numeric mode", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- setNames(nu, c("a", "b", "c"))
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- c(c = 1/2, a = 1/4, b = 1/4)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(c(1/7, 2/7, 4/7), c("a", "b", "c"))
nu <- setNames(c(1/4, 1/4, 1/2), c("a", "b", "c"))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
expect_error(kantorovich(mu, nu, dist = M))
rownames(M) <- colnames(M) <- c("a", "b", "c")
x <- kantorovich(mu, nu, dist = M)
expect_equal(x, 0.107142857142857)
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu, details = TRUE)
bestj <- attr(x, "joinings")
expect_equal(length(bestj), 1)
expect_equal(bestj[[1]], structure(c(0.142857142857143, 0.0357142857142857,
0.0714285714285714, 0, 0.25, 0, 0, 0, 0.5), .Dim = c(3L,
3L), .Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x37b2050>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
-- 5. Error: Main example - numeric mode (@test-kantorovich.R#26) -------------
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = M)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-lpSolve.R#44: kantorovich(mu, nu, dist = D, details = TRUE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-lpSolve.R#31: test_that("kantorovich_lp - nonsymmetric dist", {
mu <- c(1, 2, 4)/7
nu <- c(3, 1, 5)/9
D <- matrix(c(c(0, 1, 3), c(1, 0, 4), c(2, 4, 0)), byrow = TRUE,
nrow = 3)
x <- kantorovich_lp(mu, nu, dist = D)
expect_equal(x, 13/63)
x1 <- kantorovich_lp(mu, nu, dist = D, solution = TRUE)
x2 <- kantorovich(mu, nu, dist = D, details = TRUE)
expect_true(all.equal(attr(x1, "solution"), attr(x2, "joinings")[[1]],
tolerance = 1e-15, check.attributes = FALSE))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x37b2050>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
-- 6. Error: kantorovich_lp - nonsymmetric dist (@test-lpSolve.R#44) ----------
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = D, details = TRUE)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
== testthat results ===========================================================
[ OK: 108 | SKIPPED: 0 | WARNINGS: 0 | FAILED: 6 ]
1. Error: Pascal (@test-Pascal.R#61)
2. Error: Main example - numeric (@test-edistances.R#16)
3. Error: Main example - bigq (@test-edistances.R#53)
4. Error: kantorovich_glpk - nonsymmetric dist (@test-glpk.R#40)
5. Error: Main example - numeric mode (@test-kantorovich.R#26)
6. Error: kantorovich_lp - nonsymmetric dist (@test-lpSolve.R#44)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 2.0.0
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
...
--- re-building 'kantorovich.Rmd' using rmarkdown
Attaching package: 'gmp'
The following objects are masked from 'package:base':
%*%, apply, crossprod, matrix, tcrossprod
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2: kantorovich(mu, nu, dist = M)
where 3: eval(expr, envir, enclos)
where 4: eval(expr, envir, enclos)
where 5: withVisible(eval(expr, envir, enclos))
where 6: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 7: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 8: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 9: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 10: evaluate::evaluate(...)
where 11: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 12: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 13: block_exec(params)
where 14: call_block(x)
where 15: process_group.block(group)
where 16: process_group(group)
where 17: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 18: process_file(text, output)
where 19: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
where 20: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
output_dir = getwd(), ...)
where 21: vweave_rmarkdown(...)
where 22: engine$weave(file, quiet = quiet, encoding = enc)
where 23: doTryCatch(return(expr), name, parentenv, handler)
where 24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 25: tryCatchList(expr, classes, parentenv, handlers)
where 26: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
outputs <- c(outputs, output)
}, error = function(e) {
thisOK <<- FALSE
fails <<- c(fails, file)
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 27: tools:::buildVignettes(dir = "/home/hornik/tmp/R.check/r-devel-clang/Work/PKGS/kantorovich.Rcheck/vign_test/kantorovich",
ser_elibs = "/tmp/RtmpbNT9As/file7d2f1211495e.rds")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x722df8>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
Quitting from lines 75-84 (kantorovich.Rmd)
Error: processing vignette 'kantorovich.Rmd' failed with diagnostics:
the condition has length > 1
--- failed re-building 'kantorovich.Rmd'
SUMMARY: processing the following file failed:
'kantorovich.Rmd'
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 2.0.0
Check: tests
Result: ERROR
Running ‘testthat.R’ [3s/5s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(kantorovich)
>
> test_check("kantorovich")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-Pascal.R#61: kantorovich(as.bigq(kernel[i, ]), as.bigq(kernel[j, ]), dist = RHO[[k]])
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-Pascal.R#13: test_that("Pascal", {
library(gmp)
Pascal_Mn <- function(n) {
M <- matrix(0, nrow = n + 1, ncol = n + 2)
for (i in 1:(n + 1)) {
M[i, ][c(i, i + 1)] <- 1
}
return(M)
}
centralKernels <- function(Mn.fun, N) {
L <- Kernels <- vector("list", N)
k <- 0
M <- Mn.fun(k)
m <- nrow(M)
n <- ncol(M)
if (m != 1)
stop("M0 must have only one row")
dims0 <- as.vector(as.bigz(M))
Kernels[[k + 1]] <- matrix(as.character(dims0), dimnames = list(1:n,
1:m))
for (k in 1:N) {
M <- Mn.fun(k)
m <- nrow(M)
n <- ncol(M)
S <- apply(M, 2, function(x) which(x != 0))
dims <- as.vector(dims0 %*% M)
P <- lapply(1:n, function(i) {
as.character(dims0[S[[i]]] * M[S[[i]], i]/dims[i])
})
Kernels[[k + 1]] <- matrix("0", nrow = n, ncol = m,
dimnames = list(1:n, 1:m))
for (i in 1:n) {
Kernels[[k + 1]][i, ][S[[i]]] <- P[[i]]
}
dims0 <- dims
}
return(Kernels)
}
N <- 3
ckernels <- centralKernels(Pascal_Mn, N)
RHO <- lapply(ckernels, function(kernel) matrix("", nrow = nrow(kernel),
ncol = nrow(kernel)))
RHO[[1]] <- (diag(2) + 1)%%2
for (k in 1:N) {
diag(RHO[[k + 1]]) <- "0"
K <- nrow(RHO[[k + 1]])
kernel <- ckernels[[k + 1]]
for (i in 1:(K - 1)) {
for (j in (i + 1):K) {
RHO[[k + 1]][i, j] <- RHO[[k + 1]][j, i] <- as.character(kantorovich(as.bigq(kernel[i,
]), as.bigq(kernel[j, ]), dist = RHO[[k]]))
}
}
}
expect_identical(RHO[[4]], structure(c("0", "1/4", "1/2",
"3/4", "1", "1/4", "0", "1/4", "1/2", "3/4", "1/2", "1/4",
"0", "1/4", "1/2", "3/4", "1/2", "1/4", "0", "1/4", "1",
"3/4", "1/2", "1/4", "0"), .Dim = c(5L, 5L)))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x55b4ddc30ad8>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 1. Error: Pascal (@test-Pascal.R#61) ───────────────────────────────────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(...)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu, nu, dist = M)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1 at testthat/test-edistances.R#16: edistances(mu, nu, dist = M)
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(desc, code, env = parent.frame())
where 13 at testthat/test-edistances.R#3: test_that("Main example - numeric", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- edistances(mu, nu)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
rownames(M) <- colnames(M) <- 1:3
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
rownames(M) <- colnames(M) <- c("a", "b", "c")
expect_error(edistances(mu, nu, dist = M))
M <- matrix("1", nrow = 3, ncol = 3)
diag(M) <- "0"
expect_error(edistances(mu, nu, dist = M))
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: 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 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: 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 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: 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 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: 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 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: 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 40: 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 41: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x55b4ddc30ad8>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 2. Error: Main example - numeric (@test-edistances.R#16) ───────────────────
the condition has length > 1
Backtrace:
1. kantorovich::edistances(mu, nu, dist = M)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu, nu, dist = M)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1 at testthat/test-edistances.R#53: edistances(mu, nu, dist = M)
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(desc, code, env = parent.frame())
where 13 at testthat/test-edistances.R#40: test_that("Main example - bigq", {
mu <- as.bigq(c(1, 2, 4), 7)
nu <- as.bigq(c(1, 1, 1), c(4, 4, 2))
x <- edistances(mu, nu)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], as.bigq(9, 14))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
M <- matrix("1", nrow = 3, ncol = 3)
diag(M) <- "0"
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
M <- as.bigq(M)
expect_error(edistances(mu, nu, dist = M))
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: 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 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: 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 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: 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 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: 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 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: 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 40: 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 41: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x55b4ddc30ad8>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 3. Error: Main example - bigq (@test-edistances.R#53) ──────────────────────
the condition has length > 1
Backtrace:
1. kantorovich::edistances(mu, nu, dist = M)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-glpk.R#40: kantorovich(mu, nu, dist = D, details = TRUE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-glpk.R#27: test_that("kantorovich_glpk - nonsymmetric dist", {
mu <- c(1, 2, 4)/7
nu <- c(3, 1, 5)/9
D <- matrix(c(c(0, 1, 3), c(1, 0, 4), c(2, 4, 0)), byrow = TRUE,
nrow = 3)
x <- kantorovich_glpk(mu, nu, dist = D)
expect_equal(x, 13/63)
x1 <- kantorovich_glpk(mu, nu, dist = D, solution = TRUE)
x2 <- kantorovich(mu, nu, dist = D, details = TRUE)
expect_true(all.equal(attr(x1, "solution"), attr(x2, "joinings")[[1]],
tolerance = 1e-15, check.attributes = FALSE))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x55b4ddc30ad8>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 4. Error: kantorovich_glpk - nonsymmetric dist (@test-glpk.R#40) ───────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = D, details = TRUE)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2: kantorovich(mu, nu, dist = M)
where 3: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
where 4: withCallingHandlers({
code
NULL
}, error = function(cnd) {
if (can_entrace(cnd)) {
cnd <- cnd_entrace(cnd)
}
return_from(env, cnd)
})
where 5: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)),
...)
where 6: quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
where 7 at testthat/test-kantorovich.R#23: expect_error(kantorovich(mu, nu, dist = M))
where 8: eval(code, test_env)
where 9: eval(code, test_env)
where 10: 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 11: doTryCatch(return(expr), name, parentenv, handler)
where 12: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 13: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 14: doTryCatch(return(expr), name, parentenv, handler)
where 15: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 16: tryCatchList(expr, classes, parentenv, handlers)
where 17: 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 18: test_code(desc, code, env = parent.frame())
where 19 at testthat/test-kantorovich.R#3: test_that("Main example - numeric mode", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- setNames(nu, c("a", "b", "c"))
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- c(c = 1/2, a = 1/4, b = 1/4)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(c(1/7, 2/7, 4/7), c("a", "b", "c"))
nu <- setNames(c(1/4, 1/4, 1/2), c("a", "b", "c"))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
expect_error(kantorovich(mu, nu, dist = M))
rownames(M) <- colnames(M) <- c("a", "b", "c")
x <- kantorovich(mu, nu, dist = M)
expect_equal(x, 0.107142857142857)
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu, details = TRUE)
bestj <- attr(x, "joinings")
expect_equal(length(bestj), 1)
expect_equal(bestj[[1]], structure(c(0.142857142857143, 0.0357142857142857,
0.0714285714285714, 0, 0.25, 0, 0, 0, 0.5), .Dim = c(3L,
3L), .Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
})
where 20: eval(code, test_env)
where 21: eval(code, test_env)
where 22: 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 23: doTryCatch(return(expr), name, parentenv, handler)
where 24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 25: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 26: doTryCatch(return(expr), name, parentenv, handler)
where 27: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 28: tryCatchList(expr, classes, parentenv, handlers)
where 29: 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 30: test_code(NULL, exprs, env)
where 31: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 32: force(code)
where 33: doWithOneRestart(return(expr), restart)
where 34: withOneRestart(expr, restarts[[1L]])
where 35: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 36: 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 37: FUN(X[[i]], ...)
where 38: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 39: force(code)
where 40: doWithOneRestart(return(expr), restart)
where 41: withOneRestart(expr, restarts[[1L]])
where 42: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 43: 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 44: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 45: 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 46: 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 47: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x55b4ddc30ad8>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-kantorovich.R#26: kantorovich(mu, nu, dist = M)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-kantorovich.R#3: test_that("Main example - numeric mode", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- setNames(nu, c("a", "b", "c"))
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- c(c = 1/2, a = 1/4, b = 1/4)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(c(1/7, 2/7, 4/7), c("a", "b", "c"))
nu <- setNames(c(1/4, 1/4, 1/2), c("a", "b", "c"))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
expect_error(kantorovich(mu, nu, dist = M))
rownames(M) <- colnames(M) <- c("a", "b", "c")
x <- kantorovich(mu, nu, dist = M)
expect_equal(x, 0.107142857142857)
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu, details = TRUE)
bestj <- attr(x, "joinings")
expect_equal(length(bestj), 1)
expect_equal(bestj[[1]], structure(c(0.142857142857143, 0.0357142857142857,
0.0714285714285714, 0, 0.25, 0, 0, 0, 0.5), .Dim = c(3L,
3L), .Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x55b4ddc30ad8>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 5. Error: Main example - numeric mode (@test-kantorovich.R#26) ─────────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = M)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-lpSolve.R#44: kantorovich(mu, nu, dist = D, details = TRUE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-lpSolve.R#31: test_that("kantorovich_lp - nonsymmetric dist", {
mu <- c(1, 2, 4)/7
nu <- c(3, 1, 5)/9
D <- matrix(c(c(0, 1, 3), c(1, 0, 4), c(2, 4, 0)), byrow = TRUE,
nrow = 3)
x <- kantorovich_lp(mu, nu, dist = D)
expect_equal(x, 13/63)
x1 <- kantorovich_lp(mu, nu, dist = D, solution = TRUE)
x2 <- kantorovich(mu, nu, dist = D, details = TRUE)
expect_true(all.equal(attr(x1, "solution"), attr(x2, "joinings")[[1]],
tolerance = 1e-15, check.attributes = FALSE))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x55b4ddc30ad8>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 6. Error: kantorovich_lp - nonsymmetric dist (@test-lpSolve.R#44) ──────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = D, details = TRUE)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 108 | SKIPPED: 0 | WARNINGS: 0 | FAILED: 6 ]
1. Error: Pascal (@test-Pascal.R#61)
2. Error: Main example - numeric (@test-edistances.R#16)
3. Error: Main example - bigq (@test-edistances.R#53)
4. Error: kantorovich_glpk - nonsymmetric dist (@test-glpk.R#40)
5. Error: Main example - numeric mode (@test-kantorovich.R#26)
6. Error: kantorovich_lp - nonsymmetric dist (@test-lpSolve.R#44)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 2.0.0
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
...
--- re-building ‘kantorovich.Rmd’ using rmarkdown
Attaching package: 'gmp'
The following objects are masked from 'package:base':
%*%, apply, crossprod, matrix, tcrossprod
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2: kantorovich(mu, nu, dist = M)
where 3: eval(expr, envir, enclos)
where 4: eval(expr, envir, enclos)
where 5: withVisible(eval(expr, envir, enclos))
where 6: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 7: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 8: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 9: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 10: evaluate::evaluate(...)
where 11: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 12: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 13: block_exec(params)
where 14: call_block(x)
where 15: process_group.block(group)
where 16: process_group(group)
where 17: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 18: process_file(text, output)
where 19: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
where 20: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
output_dir = getwd(), ...)
where 21: vweave_rmarkdown(...)
where 22: engine$weave(file, quiet = quiet, encoding = enc)
where 23: doTryCatch(return(expr), name, parentenv, handler)
where 24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 25: tryCatchList(expr, classes, parentenv, handlers)
where 26: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
outputs <- c(outputs, output)
}, error = function(e) {
thisOK <<- FALSE
fails <<- c(fails, file)
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 27: tools:::buildVignettes(dir = "/home/hornik/tmp/R.check/r-devel-gcc/Work/PKGS/kantorovich.Rcheck/vign_test/kantorovich",
ser_elibs = "/home/hornik/tmp/scratch/Rtmpp43UyM/fileeac21136733.rds")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x5625f3ba4ce0>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
Quitting from lines 75-84 (kantorovich.Rmd)
Error: processing vignette 'kantorovich.Rmd' failed with diagnostics:
the condition has length > 1
--- failed re-building ‘kantorovich.Rmd’
SUMMARY: processing the following file failed:
‘kantorovich.Rmd’
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 2.0.0
Check: tests
Result: ERROR
Running ‘testthat.R’
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(kantorovich)
>
> test_check("kantorovich")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-Pascal.R#61: kantorovich(as.bigq(kernel[i, ]), as.bigq(kernel[j, ]), dist = RHO[[k]])
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-Pascal.R#13: test_that("Pascal", {
library(gmp)
Pascal_Mn <- function(n) {
M <- matrix(0, nrow = n + 1, ncol = n + 2)
for (i in 1:(n + 1)) {
M[i, ][c(i, i + 1)] <- 1
}
return(M)
}
centralKernels <- function(Mn.fun, N) {
L <- Kernels <- vector("list", N)
k <- 0
M <- Mn.fun(k)
m <- nrow(M)
n <- ncol(M)
if (m != 1)
stop("M0 must have only one row")
dims0 <- as.vector(as.bigz(M))
Kernels[[k + 1]] <- matrix(as.character(dims0), dimnames = list(1:n,
1:m))
for (k in 1:N) {
M <- Mn.fun(k)
m <- nrow(M)
n <- ncol(M)
S <- apply(M, 2, function(x) which(x != 0))
dims <- as.vector(dims0 %*% M)
P <- lapply(1:n, function(i) {
as.character(dims0[S[[i]]] * M[S[[i]], i]/dims[i])
})
Kernels[[k + 1]] <- matrix("0", nrow = n, ncol = m,
dimnames = list(1:n, 1:m))
for (i in 1:n) {
Kernels[[k + 1]][i, ][S[[i]]] <- P[[i]]
}
dims0 <- dims
}
return(Kernels)
}
N <- 3
ckernels <- centralKernels(Pascal_Mn, N)
RHO <- lapply(ckernels, function(kernel) matrix("", nrow = nrow(kernel),
ncol = nrow(kernel)))
RHO[[1]] <- (diag(2) + 1)%%2
for (k in 1:N) {
diag(RHO[[k + 1]]) <- "0"
K <- nrow(RHO[[k + 1]])
kernel <- ckernels[[k + 1]]
for (i in 1:(K - 1)) {
for (j in (i + 1):K) {
RHO[[k + 1]][i, j] <- RHO[[k + 1]][j, i] <- as.character(kantorovich(as.bigq(kernel[i,
]), as.bigq(kernel[j, ]), dist = RHO[[k]]))
}
}
}
expect_identical(RHO[[4]], structure(c("0", "1/4", "1/2",
"3/4", "1", "1/4", "0", "1/4", "1/2", "3/4", "1/2", "1/4",
"0", "1/4", "1/2", "3/4", "1/2", "1/4", "0", "1/4", "1",
"3/4", "1/2", "1/4", "0"), .Dim = c(5L, 5L)))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x3ae59a0>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 1. Error: Pascal (@test-Pascal.R#61) ───────────────────────────────────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(...)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu, nu, dist = M)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1 at testthat/test-edistances.R#16: edistances(mu, nu, dist = M)
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(desc, code, env = parent.frame())
where 13 at testthat/test-edistances.R#3: test_that("Main example - numeric", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- edistances(mu, nu)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
rownames(M) <- colnames(M) <- 1:3
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
rownames(M) <- colnames(M) <- c("a", "b", "c")
expect_error(edistances(mu, nu, dist = M))
M <- matrix("1", nrow = 3, ncol = 3)
diag(M) <- "0"
expect_error(edistances(mu, nu, dist = M))
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: 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 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: 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 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: 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 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: 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 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: 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 40: 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 41: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x3ae59a0>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 2. Error: Main example - numeric (@test-edistances.R#16) ───────────────────
the condition has length > 1
Backtrace:
1. kantorovich::edistances(mu, nu, dist = M)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu, nu, dist = M)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1 at testthat/test-edistances.R#53: edistances(mu, nu, dist = M)
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(desc, code, env = parent.frame())
where 13 at testthat/test-edistances.R#40: test_that("Main example - bigq", {
mu <- as.bigq(c(1, 2, 4), 7)
nu <- as.bigq(c(1, 1, 1), c(4, 4, 2))
x <- edistances(mu, nu)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], as.bigq(9, 14))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
M <- matrix("1", nrow = 3, ncol = 3)
diag(M) <- "0"
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
M <- as.bigq(M)
expect_error(edistances(mu, nu, dist = M))
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: 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 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: 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 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: 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 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: 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 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: 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 40: 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 41: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x3ae59a0>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 3. Error: Main example - bigq (@test-edistances.R#53) ──────────────────────
the condition has length > 1
Backtrace:
1. kantorovich::edistances(mu, nu, dist = M)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-glpk.R#40: kantorovich(mu, nu, dist = D, details = TRUE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-glpk.R#27: test_that("kantorovich_glpk - nonsymmetric dist", {
mu <- c(1, 2, 4)/7
nu <- c(3, 1, 5)/9
D <- matrix(c(c(0, 1, 3), c(1, 0, 4), c(2, 4, 0)), byrow = TRUE,
nrow = 3)
x <- kantorovich_glpk(mu, nu, dist = D)
expect_equal(x, 13/63)
x1 <- kantorovich_glpk(mu, nu, dist = D, solution = TRUE)
x2 <- kantorovich(mu, nu, dist = D, details = TRUE)
expect_true(all.equal(attr(x1, "solution"), attr(x2, "joinings")[[1]],
tolerance = 1e-15, check.attributes = FALSE))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x3ae59a0>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 4. Error: kantorovich_glpk - nonsymmetric dist (@test-glpk.R#40) ───────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = D, details = TRUE)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2: kantorovich(mu, nu, dist = M)
where 3: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
where 4: withCallingHandlers({
code
NULL
}, error = function(cnd) {
if (can_entrace(cnd)) {
cnd <- cnd_entrace(cnd)
}
return_from(env, cnd)
})
where 5: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)),
...)
where 6: quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
where 7 at testthat/test-kantorovich.R#23: expect_error(kantorovich(mu, nu, dist = M))
where 8: eval(code, test_env)
where 9: eval(code, test_env)
where 10: 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 11: doTryCatch(return(expr), name, parentenv, handler)
where 12: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 13: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 14: doTryCatch(return(expr), name, parentenv, handler)
where 15: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 16: tryCatchList(expr, classes, parentenv, handlers)
where 17: 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 18: test_code(desc, code, env = parent.frame())
where 19 at testthat/test-kantorovich.R#3: test_that("Main example - numeric mode", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- setNames(nu, c("a", "b", "c"))
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- c(c = 1/2, a = 1/4, b = 1/4)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(c(1/7, 2/7, 4/7), c("a", "b", "c"))
nu <- setNames(c(1/4, 1/4, 1/2), c("a", "b", "c"))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
expect_error(kantorovich(mu, nu, dist = M))
rownames(M) <- colnames(M) <- c("a", "b", "c")
x <- kantorovich(mu, nu, dist = M)
expect_equal(x, 0.107142857142857)
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu, details = TRUE)
bestj <- attr(x, "joinings")
expect_equal(length(bestj), 1)
expect_equal(bestj[[1]], structure(c(0.142857142857143, 0.0357142857142857,
0.0714285714285714, 0, 0.25, 0, 0, 0, 0.5), .Dim = c(3L,
3L), .Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
})
where 20: eval(code, test_env)
where 21: eval(code, test_env)
where 22: 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 23: doTryCatch(return(expr), name, parentenv, handler)
where 24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 25: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 26: doTryCatch(return(expr), name, parentenv, handler)
where 27: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 28: tryCatchList(expr, classes, parentenv, handlers)
where 29: 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 30: test_code(NULL, exprs, env)
where 31: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 32: force(code)
where 33: doWithOneRestart(return(expr), restart)
where 34: withOneRestart(expr, restarts[[1L]])
where 35: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 36: 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 37: FUN(X[[i]], ...)
where 38: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 39: force(code)
where 40: doWithOneRestart(return(expr), restart)
where 41: withOneRestart(expr, restarts[[1L]])
where 42: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 43: 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 44: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 45: 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 46: 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 47: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x3ae59a0>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-kantorovich.R#26: kantorovich(mu, nu, dist = M)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-kantorovich.R#3: test_that("Main example - numeric mode", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- setNames(nu, c("a", "b", "c"))
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- c(c = 1/2, a = 1/4, b = 1/4)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(c(1/7, 2/7, 4/7), c("a", "b", "c"))
nu <- setNames(c(1/4, 1/4, 1/2), c("a", "b", "c"))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
expect_error(kantorovich(mu, nu, dist = M))
rownames(M) <- colnames(M) <- c("a", "b", "c")
x <- kantorovich(mu, nu, dist = M)
expect_equal(x, 0.107142857142857)
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu, details = TRUE)
bestj <- attr(x, "joinings")
expect_equal(length(bestj), 1)
expect_equal(bestj[[1]], structure(c(0.142857142857143, 0.0357142857142857,
0.0714285714285714, 0, 0.25, 0, 0, 0, 0.5), .Dim = c(3L,
3L), .Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x3ae59a0>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 5. Error: Main example - numeric mode (@test-kantorovich.R#26) ─────────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = M)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-lpSolve.R#44: kantorovich(mu, nu, dist = D, details = TRUE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-lpSolve.R#31: test_that("kantorovich_lp - nonsymmetric dist", {
mu <- c(1, 2, 4)/7
nu <- c(3, 1, 5)/9
D <- matrix(c(c(0, 1, 3), c(1, 0, 4), c(2, 4, 0)), byrow = TRUE,
nrow = 3)
x <- kantorovich_lp(mu, nu, dist = D)
expect_equal(x, 13/63)
x1 <- kantorovich_lp(mu, nu, dist = D, solution = TRUE)
x2 <- kantorovich(mu, nu, dist = D, details = TRUE)
expect_true(all.equal(attr(x1, "solution"), attr(x2, "joinings")[[1]],
tolerance = 1e-15, check.attributes = FALSE))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x3ae59a0>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 6. Error: kantorovich_lp - nonsymmetric dist (@test-lpSolve.R#44) ──────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = D, details = TRUE)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 108 | SKIPPED: 0 | WARNINGS: 0 | FAILED: 6 ]
1. Error: Pascal (@test-Pascal.R#61)
2. Error: Main example - numeric (@test-edistances.R#16)
3. Error: Main example - bigq (@test-edistances.R#53)
4. Error: kantorovich_glpk - nonsymmetric dist (@test-glpk.R#40)
5. Error: Main example - numeric mode (@test-kantorovich.R#26)
6. Error: kantorovich_lp - nonsymmetric dist (@test-lpSolve.R#44)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 2.0.0
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
--- re-building ‘kantorovich.Rmd’ using rmarkdown
Attaching package: 'gmp'
The following objects are masked from 'package:base':
%*%, apply, crossprod, matrix, tcrossprod
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2: kantorovich(mu, nu, dist = M)
where 3: eval(expr, envir, enclos)
where 4: eval(expr, envir, enclos)
where 5: withVisible(eval(expr, envir, enclos))
where 6: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 7: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 8: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 9: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 10: evaluate::evaluate(...)
where 11: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 12: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 13: block_exec(params)
where 14: call_block(x)
where 15: process_group.block(group)
where 16: process_group(group)
where 17: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 18: process_file(text, output)
where 19: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
where 20: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
output_dir = getwd(), ...)
where 21: vweave_rmarkdown(...)
where 22: engine$weave(file, quiet = quiet, encoding = enc)
where 23: doTryCatch(return(expr), name, parentenv, handler)
where 24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 25: tryCatchList(expr, classes, parentenv, handlers)
where 26: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
outputs <- c(outputs, output)
}, error = function(e) {
thisOK <<- FALSE
fails <<- c(fails, file)
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 27: tools:::buildVignettes(dir = "/data/gannet/ripley/R/packages/tests-clang/kantorovich.Rcheck/vign_test/kantorovich",
ser_elibs = "/tmp/RtmpS5jFXS/file459842635b3f.rds")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x21a8b20>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
Quitting from lines 75-84 (kantorovich.Rmd)
Error: processing vignette 'kantorovich.Rmd' failed with diagnostics:
the condition has length > 1
--- failed re-building ‘kantorovich.Rmd’
SUMMARY: processing the following file failed:
‘kantorovich.Rmd’
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 2.0.0
Check: tests
Result: ERROR
Running ‘testthat.R’
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(kantorovich)
>
> test_check("kantorovich")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-Pascal.R#61: kantorovich(as.bigq(kernel[i, ]), as.bigq(kernel[j, ]), dist = RHO[[k]])
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-Pascal.R#13: test_that("Pascal", {
library(gmp)
Pascal_Mn <- function(n) {
M <- matrix(0, nrow = n + 1, ncol = n + 2)
for (i in 1:(n + 1)) {
M[i, ][c(i, i + 1)] <- 1
}
return(M)
}
centralKernels <- function(Mn.fun, N) {
L <- Kernels <- vector("list", N)
k <- 0
M <- Mn.fun(k)
m <- nrow(M)
n <- ncol(M)
if (m != 1)
stop("M0 must have only one row")
dims0 <- as.vector(as.bigz(M))
Kernels[[k + 1]] <- matrix(as.character(dims0), dimnames = list(1:n,
1:m))
for (k in 1:N) {
M <- Mn.fun(k)
m <- nrow(M)
n <- ncol(M)
S <- apply(M, 2, function(x) which(x != 0))
dims <- as.vector(dims0 %*% M)
P <- lapply(1:n, function(i) {
as.character(dims0[S[[i]]] * M[S[[i]], i]/dims[i])
})
Kernels[[k + 1]] <- matrix("0", nrow = n, ncol = m,
dimnames = list(1:n, 1:m))
for (i in 1:n) {
Kernels[[k + 1]][i, ][S[[i]]] <- P[[i]]
}
dims0 <- dims
}
return(Kernels)
}
N <- 3
ckernels <- centralKernels(Pascal_Mn, N)
RHO <- lapply(ckernels, function(kernel) matrix("", nrow = nrow(kernel),
ncol = nrow(kernel)))
RHO[[1]] <- (diag(2) + 1)%%2
for (k in 1:N) {
diag(RHO[[k + 1]]) <- "0"
K <- nrow(RHO[[k + 1]])
kernel <- ckernels[[k + 1]]
for (i in 1:(K - 1)) {
for (j in (i + 1):K) {
RHO[[k + 1]][i, j] <- RHO[[k + 1]][j, i] <- as.character(kantorovich(as.bigq(kernel[i,
]), as.bigq(kernel[j, ]), dist = RHO[[k]]))
}
}
}
expect_identical(RHO[[4]], structure(c("0", "1/4", "1/2",
"3/4", "1", "1/4", "0", "1/4", "1/2", "3/4", "1/2", "1/4",
"0", "1/4", "1/2", "3/4", "1/2", "1/4", "0", "1/4", "1",
"3/4", "1/2", "1/4", "0"), .Dim = c(5L, 5L)))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x2f77480>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 1. Error: Pascal (@test-Pascal.R#61) ───────────────────────────────────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(...)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu, nu, dist = M)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1 at testthat/test-edistances.R#16: edistances(mu, nu, dist = M)
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(desc, code, env = parent.frame())
where 13 at testthat/test-edistances.R#3: test_that("Main example - numeric", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- edistances(mu, nu)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
rownames(M) <- colnames(M) <- 1:3
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c(0.142857142857143,
0, 0.107142857142857, 0, 0, 0.25, 0, 0.285714285714286,
0.214285714285714), .Dim = c(3L, 3L), .Dimnames = list(c("1",
"2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], 0.642857142857143)
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
rownames(M) <- colnames(M) <- c("a", "b", "c")
expect_error(edistances(mu, nu, dist = M))
M <- matrix("1", nrow = 3, ncol = 3)
diag(M) <- "0"
expect_error(edistances(mu, nu, dist = M))
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: 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 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: 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 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: 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 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: 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 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: 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 40: 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 41: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x2f77480>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 2. Error: Main example - numeric (@test-edistances.R#16) ───────────────────
the condition has length > 1
Backtrace:
1. kantorovich::edistances(mu, nu, dist = M)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu, nu, dist = M)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1 at testthat/test-edistances.R#53: edistances(mu, nu, dist = M)
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(desc, code, env = parent.frame())
where 13 at testthat/test-edistances.R#40: test_that("Main example - bigq", {
mu <- as.bigq(c(1, 2, 4), 7)
nu <- as.bigq(c(1, 1, 1), c(4, 4, 2))
x <- edistances(mu, nu)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
expect_equal(x$distances[[1]], as.bigq(9, 14))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
M <- matrix("1", nrow = 3, ncol = 3)
diag(M) <- "0"
x <- edistances(mu, nu, dist = M)
expect_true(length(x[[1]]) == 15 && length(x[[2]]) == 15)
expect_equal(x$joinings[[1]], structure(c("1/7", "0", "3/28",
"0", "0", "1/4", "0", "2/7", "3/14"), .Dim = c(3L, 3L),
.Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
M <- as.bigq(M)
expect_error(edistances(mu, nu, dist = M))
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: 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 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: 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 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: 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 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: 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 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: 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 40: 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 41: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x2f77480>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 3. Error: Main example - bigq (@test-edistances.R#53) ──────────────────────
the condition has length > 1
Backtrace:
1. kantorovich::edistances(mu, nu, dist = M)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-glpk.R#40: kantorovich(mu, nu, dist = D, details = TRUE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-glpk.R#27: test_that("kantorovich_glpk - nonsymmetric dist", {
mu <- c(1, 2, 4)/7
nu <- c(3, 1, 5)/9
D <- matrix(c(c(0, 1, 3), c(1, 0, 4), c(2, 4, 0)), byrow = TRUE,
nrow = 3)
x <- kantorovich_glpk(mu, nu, dist = D)
expect_equal(x, 13/63)
x1 <- kantorovich_glpk(mu, nu, dist = D, solution = TRUE)
x2 <- kantorovich(mu, nu, dist = D, details = TRUE)
expect_true(all.equal(attr(x1, "solution"), attr(x2, "joinings")[[1]],
tolerance = 1e-15, check.attributes = FALSE))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x2f77480>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 4. Error: kantorovich_glpk - nonsymmetric dist (@test-glpk.R#40) ───────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = D, details = TRUE)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2: kantorovich(mu, nu, dist = M)
where 3: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
where 4: withCallingHandlers({
code
NULL
}, error = function(cnd) {
if (can_entrace(cnd)) {
cnd <- cnd_entrace(cnd)
}
return_from(env, cnd)
})
where 5: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)),
...)
where 6: quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
where 7 at testthat/test-kantorovich.R#23: expect_error(kantorovich(mu, nu, dist = M))
where 8: eval(code, test_env)
where 9: eval(code, test_env)
where 10: 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 11: doTryCatch(return(expr), name, parentenv, handler)
where 12: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 13: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 14: doTryCatch(return(expr), name, parentenv, handler)
where 15: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 16: tryCatchList(expr, classes, parentenv, handlers)
where 17: 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 18: test_code(desc, code, env = parent.frame())
where 19 at testthat/test-kantorovich.R#3: test_that("Main example - numeric mode", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- setNames(nu, c("a", "b", "c"))
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- c(c = 1/2, a = 1/4, b = 1/4)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(c(1/7, 2/7, 4/7), c("a", "b", "c"))
nu <- setNames(c(1/4, 1/4, 1/2), c("a", "b", "c"))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
expect_error(kantorovich(mu, nu, dist = M))
rownames(M) <- colnames(M) <- c("a", "b", "c")
x <- kantorovich(mu, nu, dist = M)
expect_equal(x, 0.107142857142857)
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu, details = TRUE)
bestj <- attr(x, "joinings")
expect_equal(length(bestj), 1)
expect_equal(bestj[[1]], structure(c(0.142857142857143, 0.0357142857142857,
0.0714285714285714, 0, 0.25, 0, 0, 0, 0.5), .Dim = c(3L,
3L), .Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
})
where 20: eval(code, test_env)
where 21: eval(code, test_env)
where 22: 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 23: doTryCatch(return(expr), name, parentenv, handler)
where 24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 25: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 26: doTryCatch(return(expr), name, parentenv, handler)
where 27: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 28: tryCatchList(expr, classes, parentenv, handlers)
where 29: 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 30: test_code(NULL, exprs, env)
where 31: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 32: force(code)
where 33: doWithOneRestart(return(expr), restart)
where 34: withOneRestart(expr, restarts[[1L]])
where 35: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 36: 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 37: FUN(X[[i]], ...)
where 38: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 39: force(code)
where 40: doWithOneRestart(return(expr), restart)
where 41: withOneRestart(expr, restarts[[1L]])
where 42: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 43: 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 44: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 45: 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 46: 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 47: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x2f77480>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-kantorovich.R#26: kantorovich(mu, nu, dist = M)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-kantorovich.R#3: test_that("Main example - numeric mode", {
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- setNames(nu, c("a", "b", "c"))
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(mu, c("a", "b", "c"))
nu <- c(c = 1/2, a = 1/4, b = 1/4)
x <- kantorovich(mu, nu)
expect_equal(x, 0.107142857142857)
mu <- setNames(c(1/7, 2/7, 4/7), c("a", "b", "c"))
nu <- setNames(c(1/4, 1/4, 1/2), c("a", "b", "c"))
M <- matrix(1, nrow = 3, ncol = 3) - diag(3)
expect_error(kantorovich(mu, nu, dist = M))
rownames(M) <- colnames(M) <- c("a", "b", "c")
x <- kantorovich(mu, nu, dist = M)
expect_equal(x, 0.107142857142857)
mu <- c(1/7, 2/7, 4/7)
nu <- c(1/4, 1/4, 1/2)
x <- kantorovich(mu, nu, details = TRUE)
bestj <- attr(x, "joinings")
expect_equal(length(bestj), 1)
expect_equal(bestj[[1]], structure(c(0.142857142857143, 0.0357142857142857,
0.0714285714285714, 0, 0.25, 0, 0, 0, 0.5), .Dim = c(3L,
3L), .Dimnames = list(c("1", "2", "3"), c("1", "2", "3"))))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x2f77480>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 5. Error: Main example - numeric mode (@test-kantorovich.R#26) ─────────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = M)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
The Kantorovich distance is achieved for 1 joining(s) among the 15 extreme joining(s), given in the 'joinings' attribute of the output.
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2 at testthat/test-lpSolve.R#44: kantorovich(mu, nu, dist = D, details = TRUE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: 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 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-lpSolve.R#31: test_that("kantorovich_lp - nonsymmetric dist", {
mu <- c(1, 2, 4)/7
nu <- c(3, 1, 5)/9
D <- matrix(c(c(0, 1, 3), c(1, 0, 4), c(2, 4, 0)), byrow = TRUE,
nrow = 3)
x <- kantorovich_lp(mu, nu, dist = D)
expect_equal(x, 13/63)
x1 <- kantorovich_lp(mu, nu, dist = D, solution = TRUE)
x2 <- kantorovich(mu, nu, dist = D, details = TRUE)
expect_true(all.equal(attr(x1, "solution"), attr(x2, "joinings")[[1]],
tolerance = 1e-15, check.attributes = FALSE))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: 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 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: 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 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: 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 41: 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 42: test_check("kantorovich")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0x2f77480>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
── 6. Error: kantorovich_lp - nonsymmetric dist (@test-lpSolve.R#44) ──────────
the condition has length > 1
Backtrace:
1. kantorovich::kantorovich(mu, nu, dist = D, details = TRUE)
2. kantorovich::edistances(mu = mu, nu = nu, dist = dist, ...)
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 108 | SKIPPED: 0 | WARNINGS: 0 | FAILED: 6 ]
1. Error: Pascal (@test-Pascal.R#61)
2. Error: Main example - numeric (@test-edistances.R#16)
3. Error: Main example - bigq (@test-edistances.R#53)
4. Error: kantorovich_glpk - nonsymmetric dist (@test-glpk.R#40)
5. Error: Main example - numeric mode (@test-kantorovich.R#26)
6. Error: kantorovich_lp - nonsymmetric dist (@test-lpSolve.R#44)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc
Version: 2.0.0
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
--- re-building ‘kantorovich.Rmd’ using rmarkdown
Attaching package: 'gmp'
The following objects are masked from 'package:base':
%*%, apply, crossprod, matrix, tcrossprod
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
kantorovich
--- call from context ---
edistances(mu = mu, nu = nu, dist = dist, ...)
--- call from argument ---
if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
} else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
} else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
--- R stacktrace ---
where 1: edistances(mu = mu, nu = nu, dist = dist, ...)
where 2: kantorovich(mu, nu, dist = M)
where 3: eval(expr, envir, enclos)
where 4: eval(expr, envir, enclos)
where 5: withVisible(eval(expr, envir, enclos))
where 6: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 7: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 8: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 9: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 10: evaluate::evaluate(...)
where 11: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 12: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 13: block_exec(params)
where 14: call_block(x)
where 15: process_group.block(group)
where 16: process_group(group)
where 17: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 18: process_file(text, output)
where 19: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
where 20: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
output_dir = getwd(), ...)
where 21: vweave_rmarkdown(...)
where 22: engine$weave(file, quiet = quiet, encoding = enc)
where 23: doTryCatch(return(expr), name, parentenv, handler)
where 24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 25: tryCatchList(expr, classes, parentenv, handlers)
where 26: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
outputs <- c(outputs, output)
}, error = function(e) {
thisOK <<- FALSE
fails <<- c(fails, file)
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 27: tools:::buildVignettes(dir = "/data/gannet/ripley/R/packages/tests-devel/kantorovich.Rcheck/vign_test/kantorovich",
ser_elibs = "/tmp/RtmplB13pR/file81de25f438ba.rds")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mu, nu, dist = NULL, ...)
{
joinings <- ejoinings(mu, nu, zeros = TRUE)
n.joinings <- length(joinings)
j1 <- joinings[[1]]
use_gmp <- class(mu) %in% c("bigq", "character")
if (is.null(dist)) {
rho <- function(x, y) discrete(x, y, gmp = use_gmp)
}
else if (class(dist) == "function") {
rho <- function(x, y) dist(x, y, ...)
}
else if (class(dist) == "matrix") {
if (!use_gmp && mode(dist) != "numeric")
stop("The dist matrix must be numeric if mu and nu are numeric")
if (nrow(dist) != length(mu) || ncol(dist) != length(nu))
stop("Invalid dimension of the dist matrix")
if (is.null(rownames(dist)))
rownames(dist) <- 1:nrow(dist)
if (is.null(colnames(dist)))
colnames(dist) <- 1:ncol(dist)
if (!setequal(rownames(j1), rownames(dist)) || !setequal(colnames(j1),
colnames(dist)))
stop("Invalid dimension names of the dist matrix")
}
else {
if (!use_gmp)
stop("dist must be a function or a numeric matrix")
if (use_gmp)
stop("dist must be a function or a numeric/character matrix")
}
if (class(dist) == "matrix") {
Rho <- dist[rownames(j1), colnames(j1)]
}
else {
if (use_gmp) {
Rho <- outer(rownames(j1), colnames(j1), FUN = Vectorize_bigq(rho))
}
else {
Rho <- outer(rownames(j1), colnames(j1), FUN = rho)
}
}
distances <- if (use_gmp)
gmp::as.bigq(numeric(n.joinings))
else numeric(n.joinings)
for (k in 1:n.joinings) {
joining <- joinings[[k]]
if (use_gmp) {
distances[k] <- sum(Rho * as.bigq(joining))
}
else {
distances[k] <- sum(Rho * joining)
}
}
out <- list(joinings = joinings, distances = distances)
return(out)
}
<bytecode: 0xa323e8>
<environment: namespace:kantorovich>
--- function search by body ---
Function edistances in namespace kantorovich has this body.
----------- END OF FAILURE REPORT --------------
Quitting from lines 75-84 (kantorovich.Rmd)
Error: processing vignette 'kantorovich.Rmd' failed with diagnostics:
the condition has length > 1
--- failed re-building ‘kantorovich.Rmd’
SUMMARY: processing the following file failed:
‘kantorovich.Rmd’
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc