tests/testthat/test_update_affiliation.R
In baruuum/btoolbox: random toolbox
context("Testing update_affiliation")
test_that("function works without lookup table", {
library("Matrix")
k = 10
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
for (ii in 1:5) {
x = sample(1:k, 5, replace = F)
# update affiliation matrix
res = update_affiliation(aff_mat, x, update_diag = TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i %in% x && j %in% x && i != j) {
expect_true(res[i, j] == 1)
} else if (i == j && i %in% x) {
expect_true(res[i, j] == 1)
} else {
expect_true(res[i, j] == 0)
}
}
}
# update affiliation matrix (no diags)
res = update_affiliation(aff_mat, x, update_diag = FALSE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i %in% x && j %in% x && i != j) {
expect_true(res[i, j] == 1)
} else if (i == j && i %in% x) {
expect_true(res[i, j] == 0)
} else {
expect_true(res[i, j] == 0)
}
}
}
}
})
test_that("function works without lookup table (list version)", {
library("Matrix")
k = 10
m = 5
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
for (ii in 1:5) {
x = lapply(1:m, function(w) sample(1:k, sample(2:6, 1), replace = F))
# update affiliation matrix
res = update_affiliation(aff_mat, x, update_diag = TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i != j) {
exp_val = sum(
sapply(x, function(w) i %in% w && j %in% w)
)
} else {
exp_val = sum(sapply(x, function(w) i %in% w))
}
expect_true(res[i, j] == exp_val)
}
}
# update affiliation matrix (no diags)
res = update_affiliation(aff_mat, x, update_diag = FALSE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i != j) {
exp_val = sum(
sapply(x, function(w) i %in% w && j %in% w)
)
} else {
exp_val = 0
}
expect_true(res[i, j] == exp_val)
}
}
}
})
test_that("function works with lookup table", {
library("Matrix")
k = 10
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
lu_tab = data.frame(index = 1:k, id = letters[1:k])
# randomly reorder indices
lu_tab = lu_tab[sample(1:k, k, replace = F), ]
for (ii in 1:5) {
x = sample(lu_tab$id, 5, replace = F)
# update affiliation matrix
res = update_affiliation(aff_mat, x, lu_tab, TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (lu_tab[lu_tab$index == i, ]$id %in% x &&
lu_tab[lu_tab$index == j, ]$id %in% x &&
i != j) {
expect_true(res[i, j] == 1)
} else if (i == j && lu_tab[lu_tab$index == i, ]$id %in% x) {
expect_true(res[i, j] == 1)
} else {
expect_true(res[i, j] == 0)
}
}
}
# update affiliation matrix (no diag)
res = update_affiliation(aff_mat, x, lu_tab, FALSE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (lu_tab[lu_tab$index == i, ]$id %in% x &&
lu_tab[lu_tab$index == j, ]$id %in% x &&
i != j) {
expect_true(res[i, j] == 1)
} else if (i == j && lu_tab[lu_tab$index == i, ]$id %in% x) {
expect_true(res[i, j] == 0)
} else {
expect_true(res[i, j] == 0)
}
}
}
}
})
test_that("function works with lookup table (list-version)", {
library("Matrix")
k = 10
m = 5
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
lu_tab = data.frame(index = 1:k, id = letters[1:k])
# randomly reorder indices
lu_tab = lu_tab[sample(1:k, k, replace = F), ]
for (ii in 1:5) {
x = lapply(1:m, function(w) sample(lu_tab$id, sample(2:6, 1), replace = F))
# update affiliation matrix
res = update_affiliation(aff_mat, x, lu_tab, TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
exp_val = if (i != j) {
sum(
sapply(x, function(w)
lu_tab[lu_tab$index == i, ]$id %in% w &&
lu_tab[lu_tab$index == j, ]$id %in% w
)
)
} else {
sum(
sapply(x, function(w)
lu_tab[lu_tab$index == i, ]$id %in% w
)
)
}
expect_true(res[i, j] == exp_val)
}
}
# update affiliation matrix (no diag)
res = update_affiliation(aff_mat, x, lu_tab, FALSE)
# check results
for (i in 1:k) {
for (j in 1:k) {
exp_val = if (i != j) {
sum(
sapply(x, function(w)
lu_tab[lu_tab$index == i, ]$id %in% w &&
lu_tab[lu_tab$index == j, ]$id %in% w
)
)
} else {
0
}
expect_true(res[i, j] == exp_val)
}
}
}
})
test_that("function thorws appropriate errors", {
library("Matrix")
k = 10
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
lu_tab = data.frame(index = 1:k, id = letters[1:k])
# randomly reorder indices
lu_tab = lu_tab[sample(1:k, k, replace = F), ]
x = sample(lu_tab$id, 5, replace = F)
y = lu_tab[lu_tab$id %in% x, ]$index
# error: non-integer x
expect_error(update_affiliation(aff_mat, y + runif(length(y))))
expect_error(update_affiliation(aff_mat, y + 0.0))
expect_error(update_affiliation(aff_mat, list(y, y + 0.0)))
# error: aff_mat not sparse
expect_error(update_affiliation(as.matrix(aff_mat), y))
# error: wrong col-names in lookup table
ltab2 = lu_tab
names(ltab2) = c("V1", "V2")
expect_error(update_affiliation(aff_mat, x, ltab2))
# error: non-integer index
names(ltab2) = names(lu_tab)
ltab2$index = ltab2$index + 0.0
expect_error(update_affiliation(aff_mat, x, ltab2))
# error: lookup is not a data.frame
expect_error(update_affiliation(aff_mat, x, as.matrix(y)))
})
test_that("R is able to pass large matrix", {
# skip test on windows 32 bit
WIN_32 = .Platform$OS.type == "windows" && .Machine$sizeof.pointer != 8
skip_if(WIN_32, "skipping large matrix test for windows 32-bit")
library("Matrix")
K = c(1e5, 1e6, 1e7)
for (k in K) {
s = sample(10:50, 1L)
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
x = sample(1:k, s, replace = F)
res = update_affiliation(aff_mat, x, update_diag = TRUE)
expect_identical(sum(res), choose(s, 2L) * 2 + s)
res2 = update_affiliation(aff_mat, x, update_diag = FALSE)
expect_identical(sum(res2), choose(s, 2L) * 2)
}
})
test_that("update is equal to t(x) %*% x", {
library("Matrix")
k = 10
m = 5
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
for (ii in 1:5) {
x = lapply(1:m, function(w) sample(1:k, sample(2:6, 1), replace = F))
# update affiliation matrix
res = update_affiliation(aff_mat, x, update_diag = TRUE)
# check results
X = matrix(0L, nrow = m, ncol = k)
for (i in 1:m) {
for (j in x[[i]]) {
X[i, j] = X[i, j] + 1L
}
}
XX = t(X) %*% X
expect_equivalent(as.matrix(res), XX)
res2 = update_affiliation(aff_mat, x, update_diag = FALSE)
XX2 = XX
diag(XX2) = rep(0, nrow(XX2))
expect_equivalent(as.matrix(res2), XX2)
}
})
test_that("normalization works as expected", {
library("Matrix")
k = 10
m = 5
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
for (ii in 1:5) {
x = lapply(1:m, function(w) sample(1:k, sample(2:6, 1), replace = F))
# update affiliation matrix
res = update_affiliation(aff_mat, x, update_diag = TRUE, normalize = TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i != j) {
exp_val = sum(
sapply(x, function(w) 1 / length(w) * (i %in% w && j %in% w))
)
} else {
exp_val = sum(sapply(x, function(w) 1 / length(w) * (i %in% w)))
}
expect_equal(res[i, j], exp_val)
}
}
# update affiliation matrix (no diags)
res = update_affiliation(aff_mat, x, update_diag = FALSE, normalize = TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i != j) {
exp_val = sum(
sapply(x, function(w) 1 / length(w) * (i %in% w && j %in% w))
)
} else {
exp_val = 0
}
expect_equal(res[i, j], exp_val)
}
}
}
})
baruuum/btoolbox documentation built on Aug. 17, 2020, 1:29 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
context("Testing update_affiliation")
test_that("function works without lookup table", {
library("Matrix")
k = 10
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
for (ii in 1:5) {
x = sample(1:k, 5, replace = F)
# update affiliation matrix
res = update_affiliation(aff_mat, x, update_diag = TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i %in% x && j %in% x && i != j) {
expect_true(res[i, j] == 1)
} else if (i == j && i %in% x) {
expect_true(res[i, j] == 1)
} else {
expect_true(res[i, j] == 0)
}
}
}
# update affiliation matrix (no diags)
res = update_affiliation(aff_mat, x, update_diag = FALSE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i %in% x && j %in% x && i != j) {
expect_true(res[i, j] == 1)
} else if (i == j && i %in% x) {
expect_true(res[i, j] == 0)
} else {
expect_true(res[i, j] == 0)
}
}
}
}
})
test_that("function works without lookup table (list version)", {
library("Matrix")
k = 10
m = 5
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
for (ii in 1:5) {
x = lapply(1:m, function(w) sample(1:k, sample(2:6, 1), replace = F))
# update affiliation matrix
res = update_affiliation(aff_mat, x, update_diag = TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i != j) {
exp_val = sum(
sapply(x, function(w) i %in% w && j %in% w)
)
} else {
exp_val = sum(sapply(x, function(w) i %in% w))
}
expect_true(res[i, j] == exp_val)
}
}
# update affiliation matrix (no diags)
res = update_affiliation(aff_mat, x, update_diag = FALSE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i != j) {
exp_val = sum(
sapply(x, function(w) i %in% w && j %in% w)
)
} else {
exp_val = 0
}
expect_true(res[i, j] == exp_val)
}
}
}
})
test_that("function works with lookup table", {
library("Matrix")
k = 10
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
lu_tab = data.frame(index = 1:k, id = letters[1:k])
# randomly reorder indices
lu_tab = lu_tab[sample(1:k, k, replace = F), ]
for (ii in 1:5) {
x = sample(lu_tab$id, 5, replace = F)
# update affiliation matrix
res = update_affiliation(aff_mat, x, lu_tab, TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (lu_tab[lu_tab$index == i, ]$id %in% x &&
lu_tab[lu_tab$index == j, ]$id %in% x &&
i != j) {
expect_true(res[i, j] == 1)
} else if (i == j && lu_tab[lu_tab$index == i, ]$id %in% x) {
expect_true(res[i, j] == 1)
} else {
expect_true(res[i, j] == 0)
}
}
}
# update affiliation matrix (no diag)
res = update_affiliation(aff_mat, x, lu_tab, FALSE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (lu_tab[lu_tab$index == i, ]$id %in% x &&
lu_tab[lu_tab$index == j, ]$id %in% x &&
i != j) {
expect_true(res[i, j] == 1)
} else if (i == j && lu_tab[lu_tab$index == i, ]$id %in% x) {
expect_true(res[i, j] == 0)
} else {
expect_true(res[i, j] == 0)
}
}
}
}
})
test_that("function works with lookup table (list-version)", {
library("Matrix")
k = 10
m = 5
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
lu_tab = data.frame(index = 1:k, id = letters[1:k])
# randomly reorder indices
lu_tab = lu_tab[sample(1:k, k, replace = F), ]
for (ii in 1:5) {
x = lapply(1:m, function(w) sample(lu_tab$id, sample(2:6, 1), replace = F))
# update affiliation matrix
res = update_affiliation(aff_mat, x, lu_tab, TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
exp_val = if (i != j) {
sum(
sapply(x, function(w)
lu_tab[lu_tab$index == i, ]$id %in% w &&
lu_tab[lu_tab$index == j, ]$id %in% w
)
)
} else {
sum(
sapply(x, function(w)
lu_tab[lu_tab$index == i, ]$id %in% w
)
)
}
expect_true(res[i, j] == exp_val)
}
}
# update affiliation matrix (no diag)
res = update_affiliation(aff_mat, x, lu_tab, FALSE)
# check results
for (i in 1:k) {
for (j in 1:k) {
exp_val = if (i != j) {
sum(
sapply(x, function(w)
lu_tab[lu_tab$index == i, ]$id %in% w &&
lu_tab[lu_tab$index == j, ]$id %in% w
)
)
} else {
0
}
expect_true(res[i, j] == exp_val)
}
}
}
})
test_that("function thorws appropriate errors", {
library("Matrix")
k = 10
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
lu_tab = data.frame(index = 1:k, id = letters[1:k])
# randomly reorder indices
lu_tab = lu_tab[sample(1:k, k, replace = F), ]
x = sample(lu_tab$id, 5, replace = F)
y = lu_tab[lu_tab$id %in% x, ]$index
# error: non-integer x
expect_error(update_affiliation(aff_mat, y + runif(length(y))))
expect_error(update_affiliation(aff_mat, y + 0.0))
expect_error(update_affiliation(aff_mat, list(y, y + 0.0)))
# error: aff_mat not sparse
expect_error(update_affiliation(as.matrix(aff_mat), y))
# error: wrong col-names in lookup table
ltab2 = lu_tab
names(ltab2) = c("V1", "V2")
expect_error(update_affiliation(aff_mat, x, ltab2))
# error: non-integer index
names(ltab2) = names(lu_tab)
ltab2$index = ltab2$index + 0.0
expect_error(update_affiliation(aff_mat, x, ltab2))
# error: lookup is not a data.frame
expect_error(update_affiliation(aff_mat, x, as.matrix(y)))
})
test_that("R is able to pass large matrix", {
# skip test on windows 32 bit
WIN_32 = .Platform$OS.type == "windows" && .Machine$sizeof.pointer != 8
skip_if(WIN_32, "skipping large matrix test for windows 32-bit")
library("Matrix")
K = c(1e5, 1e6, 1e7)
for (k in K) {
s = sample(10:50, 1L)
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
x = sample(1:k, s, replace = F)
res = update_affiliation(aff_mat, x, update_diag = TRUE)
expect_identical(sum(res), choose(s, 2L) * 2 + s)
res2 = update_affiliation(aff_mat, x, update_diag = FALSE)
expect_identical(sum(res2), choose(s, 2L) * 2)
}
})
test_that("update is equal to t(x) %*% x", {
library("Matrix")
k = 10
m = 5
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
for (ii in 1:5) {
x = lapply(1:m, function(w) sample(1:k, sample(2:6, 1), replace = F))
# update affiliation matrix
res = update_affiliation(aff_mat, x, update_diag = TRUE)
# check results
X = matrix(0L, nrow = m, ncol = k)
for (i in 1:m) {
for (j in x[[i]]) {
X[i, j] = X[i, j] + 1L
}
}
XX = t(X) %*% X
expect_equivalent(as.matrix(res), XX)
res2 = update_affiliation(aff_mat, x, update_diag = FALSE)
XX2 = XX
diag(XX2) = rep(0, nrow(XX2))
expect_equivalent(as.matrix(res2), XX2)
}
})
test_that("normalization works as expected", {
library("Matrix")
k = 10
m = 5
aff_mat = Matrix(nrow = k, ncol = k, data = 0L, sparse = TRUE)
for (ii in 1:5) {
x = lapply(1:m, function(w) sample(1:k, sample(2:6, 1), replace = F))
# update affiliation matrix
res = update_affiliation(aff_mat, x, update_diag = TRUE, normalize = TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i != j) {
exp_val = sum(
sapply(x, function(w) 1 / length(w) * (i %in% w && j %in% w))
)
} else {
exp_val = sum(sapply(x, function(w) 1 / length(w) * (i %in% w)))
}
expect_equal(res[i, j], exp_val)
}
}
# update affiliation matrix (no diags)
res = update_affiliation(aff_mat, x, update_diag = FALSE, normalize = TRUE)
# check results
for (i in 1:k) {
for (j in 1:k) {
if (i != j) {
exp_val = sum(
sapply(x, function(w) 1 / length(w) * (i %in% w && j %in% w))
)
} else {
exp_val = 0
}
expect_equal(res[i, j], exp_val)
}
}
}
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.