Description
A collection of tools and functions to adjust a variety of stochastic blockmodels (SBM). Supports at the moment Simple, Bipartite, 'Multipartite' and Multiplex SBM (undirected or directed with Bernoulli, Poisson or Gaussian emission laws on the edges, and possibly covariate for Simple and Bipartite SBM). See Léger (2016) <doi:10.48550/arXiv.1602.07587>, 'Barbillon et al.' (2020) <doi:10.1111/rssa.12193> and 'Bar-Hen et al.' (2020) <doi:10.48550/arXiv.1807.10138>.
Downloads
458
Last 30 days
7780th
458
Last 90 days
458
Last year
CRAN Check Status
1
ERROR
13
OK
Show all 14 flavors
| Flavor | Status |
|---|---|
| r-devel-linux-x86_64-debian-clang | OK |
| r-devel-linux-x86_64-debian-gcc | OK |
| r-devel-linux-x86_64-fedora-clang | OK |
| r-devel-linux-x86_64-fedora-gcc | OK |
| r-devel-macos-arm64 | ERROR |
| r-devel-windows-x86_64 | OK |
| r-oldrel-macos-arm64 | OK |
| r-oldrel-macos-x86_64 | OK |
| r-oldrel-windows-x86_64 | OK |
| r-patched-linux-x86_64 | OK |
| r-release-linux-x86_64 | OK |
| r-release-macos-arm64 | OK |
| r-release-macos-x86_64 | OK |
| r-release-windows-x86_64 | OK |
Check details (14 non-OK)
OK
r-devel-linux-x86_64-debian-clang
*
OK
r-devel-linux-x86_64-debian-gcc
*
OK
r-devel-linux-x86_64-fedora-clang
*
OK
r-devel-linux-x86_64-fedora-gcc
*
ERROR
r-devel-macos-arm64
tests
Running ‘spelling.R’ [0s/0s]
Running ‘testthat.R’ [18s/14s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(sbm)
> library(aricode)
>
> test_check("sbm")
*** caught segfault ***
address 0x110, cause 'invalid permissions'
*** caught segfault ***
address 0x110, cause 'invalid permissions'
Traceback:
1: FUN(X[[i]], ...)
2: lapply(X = X, FUN = FUN, ...)
3: sapply(1:cardE, function(e) { gr = matE[e, 1] gc = matE[e, 2] don = list_Mat[[e]] maskNA = list_MaskNA[[e]] if (v_distrib[e] == "bernoulli") { Unmdon = (1 - don) * maskNA } if (v_distrib[e] %in% c("laplace", "poisson", "gaussian", "ZIgaussian")) { Unit <- maskNA } if (v_distrib[e] == "ZIgaussian") { NonZerosdon <- (don != 0) Zerosdon <- (don == 0) * maskNA } facteur = 1 if (gc < 1) { if (gc == 0) facteur = 1/2 gc = gr } if (v_distrib[e] == "bernoulli") { prov = (tau[[gr]]) %*% log(list_theta[[e]]) %*% t(tau[[gc]]) prov1m = (tau[[gr]]) %*% log(1 - list_theta[[e]]) %*% t(tau[[gc]]) return((sum(don * prov) + sum((Unmdon) * prov1m)) * facteur) } if (v_distrib[e] == "poisson") { prov = (tau[[gr]]) %*% log(list_theta[[e]]) %*% t(tau[[gc]]) prov2 = (tau[[gr]]) %*% list_theta[[e]] %*% t(tau[[gc]]) return((sum(don * prov) - sum(Unit * prov2)) * facteur) } if (v_distrib[e] == "laplace") { prov = (tau[[gr]]) %*% log(2 * list_theta[[e]]) %*% t(tau[[gc]]) prov2 = (tau[[gr]]) %*% (1/list_theta[[e]]) %*% t(tau[[gc]]) return((-sum(Unit * prov) - sum(don * prov2)) * facteur) } if (v_distrib[e] == "gaussian") { prov = 0.5 * (tau[[gr]]) %*% (log(2 * pi * list_theta[[e]]$var) + list_theta[[e]]$mean^2/list_theta[[e]]$var) %*% t(tau[[gc]]) prov2 = 0.5 * (tau[[gr]]) %*% (1/list_theta[[e]]$var) %*% t(tau[[gc]]) prov3 = (tau[[gr]]) %*% (list_theta[[e]]$mean/list_theta[[e]]$var) %*% t(tau[[gc]]) return((-sum(Unit * prov) - sum(don^2 * prov2) + sum(don * prov3)) * facteur) } if (v_distrib[e] == "ZIgaussian") { prov = 0.5 * (tau[[gr]]) %*% (log(2 * pi * list_theta[[e]]$var) + list_theta[[e]]$mean^2/list_theta[[e]]$var) %*% t(tau[[gc]]) prov2 = 0.5 * (tau[[gr]]) %*% (1/list_theta[[e]]$var) %*% t(tau[[gc]]) prov3 = (tau[[gr]]) %*% (list_theta[[e]]$mean/list_theta[[e]]$var) %*% t(tau[[gc]]) P1 <- sum((-Unit * prov - don^2 * prov2 + don * prov3) * (1 - Zerosdon)) prov4 = (tau[[gr]]) %*% log(list_theta[[e]]$p0 + (list_theta[[e]]$p0 == 0)) %*% t(tau[[gc]]) prov4m = (tau[[gr]]) %*% log(1 - list_theta[[e]]$p0 + (list_theta[[e]]$p0 == 1)) %*% t(tau[[gc]]) P2 <- sum(Zerosdon * prov4) + sum((1 - Zerosdon) * prov4m) return((P1 + P2) * facteur) }})
4: compLikICLInt(tau, list_theta, list_pi, matE, list_Mat, list_MaskNA, n_q, v_K, v_distrib)
5: varEMMBM(self, classif, tau = tau, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
6: dataR6$estime(list_classif_init[[l]], maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
7: FUN(X[[i]], ...)
8: lapply(X = S, FUN = FUN, ...)
9: doTryCatch(return(expr), name, parentenv, handler)
10: tryCatchOne(expr, names, parentenv, handlers[[1L]])
11: tryCatchList(expr, classes, parentenv, handlers)
12: tryCatch(expr, error = function(e) { call <- conditionCall(e) if (!is.null(call)) { if (identical(call[[1L]], quote(doTryCatch))) call <- sys.call(-4L) dcall <- deparse(call, nlines = 1L) prefix <- paste("Error in", dcall, ": ") LONG <- 75L sm <- strsplit(conditionMessage(e), "\n")[[1L]] w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w") if (is.na(w)) w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b") if (w > LONG) prefix <- paste0(prefix, "\n ") } else prefix <- "Error : " msg <- paste0(prefix, conditionMessage(e), "\n") .Internal(seterrmessage(msg[1L])) if (!silent && isTRUE(getOption("show.error.messages"))) { cat(msg, file = outFile) .Internal(printDeferredWarnings()) } invisible(structure(msg, class = "try-error", condition = e))})
13: try(lapply(X = S, FUN = FUN, ...), silent = TRUE)
14: sendMaster(try(lapply(X = S, FUN = FUN, ...), silent = TRUE))
15: FUN(X[[i]], ...)
16: lapply(seq_len(cores), inner.do)
17: mclapply(1:L, function(l) { estim.c.l <- dataR6$estime(list_classif_init[[l]], maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)}, mc.cores = nbCores)
18: searchKQ(dataR6 = self, classifInit = classifInit, pastICL = pastICL, Kmin = Kmin, Kmax = Kmax, nbCores = nbCores, verbose = verbose, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
19: dataR6$searchNbClusters(classifInit, Kmin = v_Kmin, Kmax = v_Kmax, pastICL = c(), verbose = verbose, nbCores = nbCores, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
20: GREMLINS::multipartiteBM(list_Net = listNetG, v_distrib = vdistrib, namesFG = namesFG, v_Kmin = v_Kmin, v_Kmax = v_Kmax, v_Kinit = NULL, initBM = initBM, keep = TRUE, verbose = verbose, nbCores = nbCores, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
21: myMBM$optimize(estimOptions)
22: eval(code, test_env)
23: eval(code, test_env)
24: withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt)
25: doTryCatch(return(expr), name, parentenv, handler)
26: tryCatchOne(expr, names, parentenv, handlers[[1L]])
27: tryCatchList(expr, classes, parentenv, handlers)
28: tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) {
Traceback:
1: FUN(X[[i]], ...)
2: lapply(X = X, FUN = FUN, ...)
skip("On CRAN") } 3: sapply(1:cardE, function(e) { gr = matE[e, 1] gc = matE[e, 2] don = list_Mat[[e]] maskNA = list_MaskNA[[e]] if (v_distrib[e] == "bernoulli") { Unmdon = (1 - don) * maskNA } if (v_distrib[e] %in% c("laplace", "poisson", "gaussian", "ZIgaussian")) { Unit <- maskNA } if (v_distrib[e] == "ZIgaussian") { NonZerosdon <- (don != 0) else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) Zerosdon <- (don == 0) * maskNA } facteur = 1 if (gc < 1) { if (gc == 0) facteur = 1/2 gc = gr } if (v_distrib[e] == "bernoulli") { prov = (tau[[gr]]) %*% log(list_theta[[e]]) %*% t(tau[[gc]]) prov1m = (tau[[gr]]) %*% log(1 - list_theta[[e]]) %*% t(tau[[gc]]) return((sum(don * prov) + sum((Unmdon) * prov1m)) * facteur) } if (v_distrib[e] == "poisson") { prov = (tau[[gr]]) %*% log(list_theta[[e]]) %*% t(tau[[gc]]) prov2 = (tau[[gr]]) %*% list_theta[[e]] %*% t(tau[[gc]]) return((sum(don * prov) - sum(Unit * prov2)) * facteur) } if (v_distrib[e] == "laplace") { prov = (tau[[gr]]) %*% log(2 * list_theta[[e]]) %*% t(tau[[gc]]) prov2 = (tau[[gr]]) %*% (1/list_theta[[e]]) %*% t(tau[[gc]]) return((-sum(Unit * prov) - sum(don * prov2)) * facteur) } if (v_distrib[e] == "gaussian") { prov = 0.5 * (tau[[gr]]) %*% (log(2 * pi * list_theta[[e]]$var) + list_theta[[e]]$mean^2/list_theta[[e]]$var) %*% t(tau[[gc]]) prov2 = 0.5 * (tau[[gr]]) %*% (1/list_theta[[e]]$var) %*% t(tau[[gc]]) prov3 = (tau[[gr]]) %*% (list_theta[[e]]$mean/list_theta[[e]]$var) %*% t(tau[[gc]]) return((-sum(Unit * prov) - sum(don^2 * prov2) + sum(don * prov3)) * facteur) } if (v_distrib[e] == "ZIgaussian") { prov = 0.5 * (tau[[gr]]) %*% (log(2 * pi * list_theta[[e]]$var) + list_theta[[e]]$mean^2/list_theta[[e]]$var) %*% t(tau[[gc]]) prov2 = 0.5 * (tau[[gr]]) %*% (1/list_theta[[e]]$var) %*% t(tau[[gc]]) prov3 = (tau[[gr]]) %*% (list_theta[[e]]$mean/list_theta[[e]]$var) %*% t(tau[[gc]]) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal)
29: doWithOneRestart(return(expr), restart)
30: P1 <- sum((-Unit * prov - don^2 * prov2 + don * prov3) * (1 - Zerosdon)) prov4 = (tau[[gr]]) %*% log(list_theta[[e]]$p0 + (list_theta[[e]]$p0 == 0)) %*% t(tau[[gc]]) prov4m = (tau[[gr]]) %*% log(1 - list_theta[[e]]$p0 + (list_theta[[e]]$p0 == 1)) %*% t(tau[[gc]]) P2 <- sum(Zerosdon * prov4) + sum((1 - Zerosdon) * prov4m) return((P1 + P2) * facteur) }})
4: compLikICLInt(tau, list_theta, list_pi, matE, list_Mat, list_MaskNA, n_q, v_K, v_distrib)withOneRestart(expr, restarts[[1L]])
31: withRestarts(tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) {
5: varEMMBM(self, classif, tau = tau, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
6: dataR6$estime(list_classif_init[[l]], maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
7: FUN(X[[i]], ...)
skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) } 8: lapply(X = S, FUN = FUN, ...)
9: doTryCatch(return(expr), name, parentenv, handler)
10: tryCatchOne(expr, names, parentenv, handlers[[1L]])
11: tryCatchList(expr, classes, parentenv, handlers)
12: tryCatch(expr, error = function(e) { call <- conditionCall(e) if (!is.null(call)) { if (identical(call[[1L]], quote(doTryCatch))) call <- sys.call(-4L) dcall <- deparse(call, nlines = 1L) prefix <- paste("Error in", dcall, ": ") LONG <- 75L sm <- strsplit(conditionMessage(e), "\n")[[1L]] w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w") if (is.na(w)) w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b") if (w > LONG) prefix <- paste0(prefix, "\n ") } else prefix <- "Error : " msg <- paste0(prefix, conditionMessage(e), "\n")}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal), end_test = function() { })
32: test_code(code, parent.frame())
33: test_that("initializing Multipartite SBM works", { if (Sys.info()["sysname"] != "Windows") { set.seed(2) npc <- 30 Q <- 3 n <- npc * Q Z <- diag(Q) %x% matrix(1, npc, 1) P <- matrix(runif(Q * Q), Q, Q) A <- 1 * (matrix(runif(n * n), n, n) < Z %*% P %*% t(Z)) B <- matrix(rpois(npc * Q * 20, 2), npc * Q, 20) netA <- defineSBM(A, "bernoulli", type = "simple", directed = TRUE, dimLabels = c("Actor")) netB <- defineSBM(B, "poisson", type = "bipartite", dimLabels = c("Actor", "Stuff")) myMBM <- MultipartiteSBM_fit$new(list(netA, netB)) expect_true(inherits(myMBM, "SBM")) .Internal(seterrmessage(msg[1L])) if (!silent && isTRUE(getOption("show.error.messages"))) { cat(msg, file = outFile) .Internal(printDeferredWarnings()) } invisible(structure(msg, class = "try-error", condition = e))})
13: try(lapply(X = S, FUN = FUN, ...), silent = TRUE)
14: sendMaster(try(lapply(X = S, FUN = FUN, ...), silent = TRUE))
15: FUN(X[[i]], ...)
16: lapply(seq_len(cores), inner.do) expect_true(inherits(myMBM, "MultipartiteSBM")) expect_true(inherits(myMBM, "MultipartiteSBM_fit")) expect_equal(myMBM$modelName, c("bernoulli", "poisson")) expect_true(is.character(myMBM$modelName)) expect_equal(unname(myMBM$nbNodes), c(Q * npc, 20)) expect_equal(myMBM$directed, c(TRUE, NA)) expect_equal(myMBM$nbNetworks, 2) expect_equal(unname(myMBM$networkData[[1]]$nbNodes), Q * npc) expect_equal(unname(myMBM$networkData[[2]]$nbNodes), c(Q * npc, 20)) expect_equal(unname(myMBM$architecture), matrix(c(1, 1, 1, 2), 2, 2)) if (packageVersion("purrr") >= "1.0.0") { expect_equal(myMBM$blockProp, list(numeric(0), list(numeric(0), numeric(0)))) } expect_equal(myMBM$connectParam, list(list(mean = matrix(0, 0, 0)), list(mean = matrix(0, 0, 0)))) expect_equal(coef(myMBM, "connectivity"), myMBM$connectParam) expect_equal(coef(myMBM, "block"), myMBM$blockProp) estimOptions = list(initBM = FALSE, verbosity = 0, nbCores = 2) myMBM$optimize(estimOptions)
17: mclapply(1:L, function(l) { estim.c.l <- dataR6$estime(list_classif_init[[l]], maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)}, mc.cores = nbCores)
18: searchKQ(dataR6 = self, classifInit = classifInit, pastICL = pastICL, Kmin = Kmin, Kmax = Kmax, nbCores = nbCores, verbose = verbose, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
19: dataR6$searchNbClusters(classifInit, Kmin = v_Kmin, Kmax = v_Kmax, pastICL = c(), verbose = verbose, nbCores = nbCores, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
20: GREMLINS::multipartiteBM(list_Net = listNetG, v_distrib = vdistrib, namesFG = namesFG, v_Kmin = v_Kmin, v_Kmax = v_Kmax, v_Kinit = NULL, initBM = initBM, keep = TRUE, verbose = verbose, nbCores = nbCores, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
21: myMBM$optimize(estimOptions)
22: eval(code, test_env)
expect_equal(length(myMBM$networkData[[1]]$memberships), npc * Q) expect_equal(is.list(myMBM$networkData[[2]]$memberships), TRUE) expect_equal(length(myMBM$networkData[[1]]$blockProp), length(unique(myMBM$networkData[[1]]$memberships))) expect_equal(myMBM$networkData[[1]]$blockProp, myMBM$networkData[[2]]$blockProp[[1]]) expect_equal(length(myMBM$networkData[[1]]$blockProp), nrow(myMBM$networkData[[1]]$connectParam$mean)) expect_equal(ncol(myMBM$networkData[[1]]$connectParam$mean), nrow(myMBM$networkData[[1]]$connectParam$mean)) muAS <- myMBM$networkData[[2]]$connectParam$mean23: eval(code, test_env)
24: withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } expect_equal(ifelse(is.matrix(muAS), nrow(muAS), length(muAS)), nrow(myMBM$networkData[[1]]$connectParam$mean)) expect_equal(lengths(myMBM$blockProp), myMBM$nbBlocks) expect_equal(length(myMBM$blockProp), length(myMBM$dimLabels)) expect_equal(length(myMBM$connectParam), myMBM$nbNetworks) expect_equal(lengths(myMBM$memberships), myMBM$nbNodes) else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt)
25: doTryCatch(return(expr), name, parentenv, handler)
26: tryCatchOne(expr, names, parentenv, handlers[[1L]])
27: tryCatchList(expr, classes, parentenv, handlers)
28: tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() expect_lt(myMBM$loglik, 0) expect_lt(myMBM$ICL, 0) expect_lt(myMBM$ICL, myMBM$loglik) expect_silent(plot(myMBM, type = "data")) expect_silent(plot(myMBM, type = "meso")) expect_silent(plot(myMBM, type = "expected")) expect_equal(coef(myMBM, "connectivity"), myMBM$connectParam) expect_equal(coef(myMBM, "block"), myMBM$blockProp) expect_lt(rmse(myMBM$connectParam[[1]]$mean, netA$connectParam$mean), 0.01) expect_lt(rmse(myMBM$connectParam[[2]]$mean, netB$connectParam$mean), 0.01) }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal) expect_lt(1 - aricode::ARI(myMBM$memberships$Actor, netA$memberships), 0.05) }})
34: eval(code, test_env)
35:
29: doWithOneRestart(return(expr), restart)
30: withOneRestart(expr, restarts[[1L]])
31: withRestarts(tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) {eval(code, test_env)
36: withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt)
37: doTryCatch(return(expr), name, parentenv, handler)
38: tryCatchOne(expr, names, parentenv, handlers[[1L]]) skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal), end_test = function() { })
32: test_code(code, parent.frame())
33: test_that("initializing Multipartite SBM works", { if (Sys.info()["sysname"] != "Windows") { set.seed(2) npc <- 30
39: tryCatchList(expr, classes, parentenv, handlers)
40: tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { Q <- 3 n <- npc * Q Z <- diag(Q) %x% matrix(1, npc, 1) P <- matrix(runif(Q * Q), Q, Q) A <- 1 * (matrix(runif(n * n), n, n) < Z %*% P %*% t(Z)) B <- matrix(rpois(npc * Q * 20, 2), npc * Q, 20) netA <- defineSBM(A, "bernoulli", type = "simple", directed = TRUE, dimLabels = c("Actor")) netB <- defineSBM(B, "poisson", type = "bipartite", dimLabels = c("Actor", "Stuff")) myMBM <- MultipartiteSBM_fit$new(list(netA, netB)) expect_true(inherits(myMBM, "SBM")) expect_true(inherits(myMBM, "MultipartiteSBM")) expect_true(inherits(myMBM, "MultipartiteSBM_fit")) expect_equal(myMBM$modelName, c("bernoulli", "poisson")) expect_true(is.character(myMBM$modelName)) expect_equal(unname(myMBM$nbNodes), c(Q * npc, 20)) expect_equal(myMBM$directed, c(TRUE, NA)) expect_equal(myMBM$nbNetworks, 2) expect_equal(unname(myMBM$networkData[[1]]$nbNodes), Q * npc) expect_equal(unname(myMBM$networkData[[2]]$nbNodes), c(Q * npc, 20)) skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal)
41: doWithOneRestart(return(expr), restart)
42: withOneRestart(expr, restarts[[1L]])
43: withRestarts(tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal), end_test = function() { })
44: test_code(code = exprs, env = env, reporter = get_reporter() %||% StopReporter$new())
45: source_file(path, env = env(env), desc = desc, shuffle = shuffle, error_call = error_call)
expect_equal(unname(myMBM$architecture), matrix(c(1, 1, 1, 2), 2, 2)) if (packageVersion("purrr") >= "1.0.0") { expect_equal(myMBM$blockProp, list(numeric(0), list(numeric(0), numeric(0)))) } expect_equal(myMBM$connectParam, list(list(mean = matrix(0, 0, 0)), list(mean = matrix(0, 0, 0))))46: FUN(X[[i]], ...)
47: lapply(test_paths, test_one_file, env = env, desc = desc, shuffle = shuffle, error_call = error_call)
48: doTryCatch(return(expr), name, parentenv, handler)
49: tryCatchOne(expr, names, parentenv, handlers[[1L]])
50: tryCatchList(expr, classes, parentenv, handlers)
51: tryCatch(code, testthat_abort_reporter = function(cnd) { cat(conditionMessage(cnd), "\n") NULL})
52: with_reporter(reporters$multi, lapply(test_paths, test_one_file, env = env, desc = desc, shuffle = shuffle, error_call = error_call))
53: test_files_serial(test_dir = test_dir, test_package = test_package, test_paths = test_paths, load_helpers = load_helpers, reporter = reporter, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, expect_equal(coef(myMBM, "connectivity"), myMBM$connectParam) expect_equal(coef(myMBM, "block"), myMBM$blockProp) estimOptions = list(initBM = FALSE, verbosity = 0, nbCores = 2) myMBM$optimize(estimOptions) expect_equal(length(myMBM$networkData[[1]]$memberships), npc * Q) expect_equal(is.list(myMBM$networkData[[2]]$memberships), TRUE) expect_equal(length(myMBM$networkData[[1]]$blockProp), length(unique(myMBM$networkData[[1]]$memberships))) expect_equal(myMBM$networkData[[1]]$blockProp, myMBM$networkData[[2]]$blockProp[[1]]) expect_equal(length(myMBM$networkData[[1]]$blockProp), nrow(myMBM$networkData[[1]]$connectParam$mean)) expect_equal(ncol(myMBM$networkData[[1]]$connectParam$mean), nrow(myMBM$networkData[[1]]$connectParam$mean)) muAS <- myMBM$networkData[[2]]$connectParam$mean expect_equal(ifelse(is.matrix(muAS), nrow(muAS), length(muAS)), nrow(myMBM$networkData[[1]]$connectParam$mean)) expect_equal(lengths(myMBM$blockProp), myMBM$nbBlocks) expect_equal(length(myMBM$blockProp), length(myMBM$dimLabels)) expect_equal(length(myMBM$connectParam), myMBM$nbNetworks) expect_equal(lengths(myMBM$memberships), myMBM$nbNodes) expect_lt(myMBM$loglik, 0) expect_lt(myMBM$ICL, 0) expect_lt(myMBM$ICL, myMBM$loglik) expect_silent(plot(myMBM, type = "data")) desc = desc, load_package = load_package, shuffle = shuffle, error_call = error_call)
54: test_files(test_dir = path, test_paths = test_paths, test_package = package, reporter = reporter, load_helpers = load_helpers, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, load_package = load_package, parallel = parallel, shuffle = shuffle)
55: test_dir("testthat", package = package, reporter = reporter, ..., load_package = "installed")
56: test_check("sbm")
An irrecoverable exception occurred. R is aborting now ...
expect_silent(plot(myMBM, type = "meso")) expect_silent(plot(myMBM, type = "expected")) expect_equal(coef(myMBM, "connectivity"), myMBM$connectParam) expect_equal(coef(myMBM, "block"), myMBM$blockProp) expect_lt(rmse(myMBM$connectParam[[1]]$mean, netA$connectParam$mean), 0.01) expect_lt(rmse(myMBM$connectParam[[2]]$mean, netB$connectParam$mean), 0.01) expect_lt(1 - aricode::ARI(myMBM$memberships$Actor, netA$memberships), 0.05) }})
34: eval(code, test_env)
35: eval(code, test_env)
36: withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt)
37: doTryCatch(return(expr), name, parentenv, handler)
38: tryCatchOne(expr, names, parentenv, handlers[[1L]])
39: tryCatchList(expr, classes, parentenv, handlers)
40: tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal)
41: doWithOneRestart(return(expr), restart)
42: withOneRestart(expr, restarts[[1L]])
43: withRestarts(tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal), end_test = function() { })
44: test_code(code = exprs, env = env, reporter = get_reporter() %||% StopReporter$new())
45: source_file(path, env = env(env), desc = desc, shuffle = shuffle, error_call = error_call)
46: FUN(X[[i]], ...)
47: lapply(test_paths, test_one_file, env = env, desc = desc, shuffle = shuffle, error_call = error_call)
48: doTryCatch(return(expr), name, parentenv, handler)
49: tryCatchOne(expr, names, parentenv, handlers[[1L]])
50: tryCatchList(expr, classes, parentenv, handlers)
51: tryCatch(code, testthat_abort_reporter = function(cnd) { cat(conditionMessage(cnd), "\n") NULL})
52: with_reporter(reporters$multi, lapply(test_paths, test_one_file, env = env, desc = desc, shuffle = shuffle, error_call = error_call))
53: test_files_serial(test_dir = test_dir, test_package = test_package, test_paths = test_paths, load_helpers = load_helpers, reporter = reporter, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, desc = desc, load_package = load_package, shuffle = shuffle, error_call = error_call)
54: test_files(test_dir = path, test_paths = test_paths, test_package = package, reporter = reporter, load_helpers = load_helpers, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, load_package = load_package, parallel = parallel, shuffle = shuffle)
55: test_dir("testthat", package = package, reporter = reporter, ..., load_package = "installed")
56: test_check("sbm")
An irrecoverable exception occurred. R is aborting now ...
Saving _problems/test-MultipartiteSBM-47.R
[1] "------------Nb of entities in each functional group--------------"
Actor
90
[1] "------------Probability distributions on each network--------------"
[1] "bernoulli" "bernoulli" "poisson"
[1] "-------------------------------------------------------------------"
[1] " ------ Searching the numbers of blocks starting from [ 1 ] blocks"
[1] "ICL : -18262.1 . Nb of blocks: [ 1 ]"
[1] "ICL : -14768.26 . Nb of blocks: [ 2 ]"
*** caught segfault ***
address 0x110, cause 'invalid permissions'
Traceback:
1: FUN(X[[i]], ...)
2: lapply(X = X, FUN = FUN, ...)
3: sapply(1:cardE, function(e) { gr = matE[e, 1] gc = matE[e, 2] don = list_Mat[[e]] maskNA = list_MaskNA[[e]] if (v_distrib[e] == "bernoulli") { Unmdon = (1 - don) * maskNA } if (v_distrib[e] %in% c("laplace", "poisson", "gaussian", "ZIgaussian")) { Unit <- maskNA } if (v_distrib[e] == "ZIgaussian") { NonZerosdon <- (don != 0) Zerosdon <- (don == 0) * maskNA } facteur = 1 if (gc < 1) { if (gc == 0) facteur = 1/2 gc = gr } if (v_distrib[e] == "bernoulli") { prov = (tau[[gr]]) %*% log(list_theta[[e]]) %*% t(tau[[gc]]) prov1m = (tau[[gr]]) %*% log(1 - list_theta[[e]]) %*% t(tau[[gc]]) return((sum(don * prov) + sum((Unmdon) * prov1m)) * facteur) } if (v_distrib[e] == "poisson") { prov = (tau[[gr]]) %*% log(list_theta[[e]]) %*% t(tau[[gc]]) prov2 = (tau[[gr]]) %*% list_theta[[e]] %*% t(tau[[gc]]) return((sum(don * prov) - sum(Unit * prov2)) * facteur) } if (v_distrib[e] == "laplace") { prov = (tau[[gr]]) %*% log(2 * list_theta[[e]]) %*% t(tau[[gc]]) prov2 = (tau[[gr]]) %*% (1/list_theta[[e]]) %*% t(tau[[gc]]) return((-sum(Unit * prov) - sum(don * prov2)) * facteur) } if (v_distrib[e] == "gaussian") { prov = 0.5 * (tau[[gr]]) %*% (log(2 * pi * list_theta[[e]]$var) + list_theta[[e]]$mean^2/list_theta[[e]]$var) %*% t(tau[[gc]]) prov2 = 0.5 * (tau[[gr]]) %*% (1/list_theta[[e]]$var) %*% t(tau[[gc]]) prov3 = (tau[[gr]]) %*% (list_theta[[e]]$mean/list_theta[[e]]$var) %*% t(tau[[gc]]) return((-sum(Unit * prov) - sum(don^2 * prov2) + sum(don * prov3)) * facteur) } if (v_distrib[e] == "ZIgaussian") { prov = 0.5 * (tau[[gr]]) %*% (log(2 * pi * list_theta[[e]]$var) + list_theta[[e]]$mean^2/list_theta[[e]]$var) %*% t(tau[[gc]]) prov2 = 0.5 * (tau[[gr]]) %*% (1/list_theta[[e]]$var) %*% t(tau[[gc]]) prov3 = (tau[[gr]]) %*% (list_theta[[e]]$mean/list_theta[[e]]$var) %*% t(tau[[gc]]) P1 <- sum((-Unit * prov - don^2 * prov2 + don * prov3) * (1 - Zerosdon)) prov4 = (tau[[gr]]) %*% log(list_theta[[e]]$p0 + (list_theta[[e]]$p0 == 0)) %*% t(tau[[gc]]) prov4m = (tau[[gr]]) %*% log(1 - list_theta[[e]]$p0 + (list_theta[[e]]$p0 == 1)) %*% t(tau[[gc]]) P2 <- sum(Zerosdon * prov4) + sum((1 - Zerosdon) * prov4m) return((P1 + P2) * facteur) }})
4: compLikICLInt(tau, list_theta, list_pi, matE, list_Mat, list_MaskNA, n_q, v_K, v_distrib)
5: varEMMBM(self, classif, tau = tau, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
6: dataR6$estime(list_classif_init[[l]], maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
7: FUN(X[[i]], ...)
8: lapply(X = S, FUN = FUN, ...)
9: doTryCatch(return(expr), name, parentenv, handler)
10: tryCatchOne(expr, names, parentenv, handlers[[1L]])
11: tryCatchList(expr, classes, parentenv, handlers)
12: tryCatch(expr, error = function(e) { call <- conditionCall(e) if (!is.null(call)) { if (identical(call[[1L]], quote(doTryCatch))) call <- sys.call(-4L) dcall <- deparse(call, nlines = 1L) prefix <- paste("Error in", dcall, ": ") LONG <- 75L sm <- strsplit(conditionMessage(e), "\n")[[1L]] w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w") if (is.na(w)) w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b") if (w > LONG) prefix <- paste0(prefix, "\n ") } else prefix <- "Error : " msg <- paste0(prefix, conditionMessage(e), "\n") .Internal(seterrmessage(msg[1L])) if (!silent && isTRUE(getOption("show.error.messages"))) { cat(msg, file = outFile) .Internal(printDeferredWarnings()) } invisible(structure(msg, class = "try-error", condition = e))})
13: try(lapply(X = S, FUN = FUN, ...), silent = TRUE)
14: sendMaster(try(lapply(X = S, FUN = FUN, ...), silent = TRUE))
15: FUN(X[[i]], ...)
16: lapply(seq_len(cores), inner.do)
17: mclapply(X, FUN, ..., mc.cores = mc.cores, mc.preschedule = mc.preschedule, mc.set.seed = mc.set.seed, mc.cleanup = mc.cleanup, mc.allow.recursive = mc.allow.recursive)
18: pbmcapply::pbmclapply(1:L, function(l) { estim.c.l <- dataR6$estime(list_classif_init[[l]], maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)}, mc.cores = nbCores)
19: searchKQ(dataR6 = self, classifInit = classifInit, pastICL = pastICL, Kmin = Kmin, Kmax = Kmax, nbCores = nbCores, verbose = verbose, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
20: dataR6$searchNbClusters(classifInit, Kmin = v_Kmin, Kmax = v_Kmax, pastICL = c(), verbose = verbose, nbCores = nbCores, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
21: GREMLINS::multipartiteBM(list_Net = listNetG, v_distrib = vdistrib, namesFG = namesFG, v_Kmin = v_Kmin, v_Kmax = v_Kmax, v_Kinit = NULL, initBM = initBM, keep = TRUE, verbose = verbose, nbCores = nbCores, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
22: super$optimize(estimOptions)
23: myMultiplexFitindep$optimize(estimOptions = currentOptions)
24: eval(code, test_env)
25: eval(code, test_env)
26: withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt)
27: doTryCatch(return(expr), name, parentenv, handler)
28: tryCatchOne(expr, names, parentenv, handlers[[1L]])
29: tryCatchList(expr, classes, parentenv, handlers)
30: tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal)
31: doWithOneRestart(return(expr), restart)
32: withOneRestart(expr, restarts[[1L]])
33: withRestarts(tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal), end_test = function() { })
34: test_code(code, parent.frame())
35: test_that("Inference for Multiplex networks", { if (Sys.info()["sysname"] != "Windows") { set.seed(2) npc <- 30 Q <- 3 n <- npc * Q Z <- diag(Q) %x% matrix(1, npc, 1) P <- matrix(runif(Q * Q), Q, Q) A <- 1 * (matrix(runif(n * n), n, n) < Z %*% P %*% t(Z)) type <- "simple" netA <- defineSBM(A, "bernoulli", type = "simple", directed = TRUE, dimLabels = c("Actor")) B <- 1 * (matrix(runif(n * n), n, n) < Z %*% P %*% t(Z)) netB <- defineSBM(B, "bernoulli", type = "simple", dimLabels = c("Actor")) myMultiplex <- MultiplexSBM_fit$new(list(netA, netB)) netC <- defineSBM(B, "poisson", type = "simple", dimLabels = c("Actor")) expect_equal(myMultiplex$directed, c(TRUE, TRUE)) expect_equal(myMultiplex$nbNetworks, 2) expect_equal(myMultiplex$dependentNetwork, FALSE) expect_equal(MultiplexSBM_fit$new(list(netA, netB), TRUE)$dependentNetwork, TRUE) expect_error(MultiplexSBM_fit$new(list(netA, netC), TRUE)) expect_error(MultiplexSBM_fit$new(list(netA, netB, netB), TRUE)) currentOptions <- list(verbosity = 1, nbBlocksRange = list(c(1, 10)), nbCores = 2, maxiterVE = 100, maxiterVEM = 100, initBM = TRUE) myMultiplexFitindep <- MultiplexSBM_fit$new(list(netA, netB, netC)) myMultiplexFitindep$optimize(estimOptions = currentOptions) expect_equal(length(myMultiplexFitindep$connectParam), 3) myMultiplexFitdep <- MultiplexSBM_fit$new(list(netA, netB), dependentNet = TRUE) currentOptions <- list(verbosity = 3, plot = TRUE, explorFactor = 1.5, nbBlocksRange = c(4, Inf), nbCores = 2, fast = TRUE) myMultiplexFitdep$optimize(estimOptions = currentOptions) myMultiplexFitdep$probMemberships expect_equal(class(myMultiplexFitdep$memberships), "list") expect_equal(length(myMultiplexFitdep$connectParam), 4) expect_equal(myMultiplexFitdep$dependentNetwork, TRUE) set.seed(2) npc1 <- 30 npc2 <- 20 Q1 <- 2 Q2 <- 3 n1 <- npc1 * Q1 n2 <- npc2 * Q2 Z1 <- diag(Q1) %x% matrix(1, npc1, 1) Z2 <- diag(Q2) %x% matrix(1, npc2, 1) P <- matrix(runif(Q1 * Q2), Q1, Q2) A <- 1 * (matrix(runif(n1 * n2), n1, n2) < Z1 %*% P %*% t(Z2)) netA <- defineSBM(A, "bernoulli", type = "bipartite", directed = TRUE, dimLabels = c("Actor", "Object")) B <- 1 * (matrix(runif(n1 * n2), n1, n2) < Z1 %*% P %*% t(Z2)) netB <- defineSBM(B, "bernoulli", type = "bipartite", dimLabels = c("Actor", "Object")) myMultiplexFitindep <- MultiplexSBM_fit$new(list(netA, netB)) currentOptions <- list(verbosity = 1, nbBlocksRange = list(c(1, 10), c(1, 10)), nbCores = 2, maxiterVE = 100, maxiterVEM = 100, initBM = FALSE) names(currentOptions$nbBlocksRange) = c("Actor", "Object") myMultiplexFitindep$optimize(currentOptions) expect_equal(length(myMultiplexFitindep$connectParam), 2) }})
36: eval(code, test_env)
37: eval(code, test_env)
38: withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt)
39: doTryCatch(return(expr), name, parentenv, handler)
40: tryCatchOne(expr, names, parentenv, handlers[[1L]])
41: tryCatchList(expr, classes, parentenv, handlers)
42: tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal)
43: doWithOneRestart(return(expr), restart)
44: withOneRestart(expr, restarts[[1L]])
45: withRestarts(tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal), end_test = function() { })
46: test_code(code = exprs, env = env, reporter = get_reporter() %||% StopReporter$new())
47: source_file(path, env = env(env), desc = desc, shuffle = shuffle, error_call = error_call)
48: FUN(X[[i]], ...)
49: lapply(test_paths, test_one_file, env = env, desc = desc, shuffle = shuffle, error_call = error_call)
50: doTryCatch(return(expr), name, parentenv, handler)
51: tryCatchOne(expr, names, parentenv, handlers[[1L]])
52: tryCatchList(expr, classes, parentenv, handlers)
53: tryCatch(code, testthat_abort_reporter = function(cnd) { cat(conditionMessage(cnd), "\n") NULL})
54: with_reporter(reporters$multi, lapply(test_paths, test_one_file, env = env, desc = desc, shuffle = shuffle, error_call = error_call))
55: test_files_serial(test_dir = test_dir, test_package = test_package, test_paths = test_paths, load_helpers = load_helpers, reporter = reporter, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, desc = desc, load_package = load_package, shuffle = shuffle, error_call = error_call)
56: test_files(test_dir = path, test_paths = test_paths, test_package = package, reporter = reporter, load_helpers = load_helpers, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, load_package = load_package, parallel = parallel, shuffle = shuffle)
57: test_dir("testthat", package = package, reporter = reporter, ..., load_package = "installed")
58: test_check("sbm")
An irrecoverable exception occurred. R is aborting now ...
*** caught segfault ***
address 0x110, cause 'invalid permissions'
Traceback:
1: FUN(X[[i]], ...)
2: lapply(X = X, FUN = FUN, ...)
3: sapply(1:cardE, function(e) { gr = matE[e, 1] gc = matE[e, 2] don = list_Mat[[e]] maskNA = list_MaskNA[[e]] if (v_distrib[e] == "bernoulli") { Unmdon = (1 - don) * maskNA } if (v_distrib[e] %in% c("laplace", "poisson", "gaussian", "ZIgaussian")) { Unit <- maskNA } if (v_distrib[e] == "ZIgaussian") { NonZerosdon <- (don != 0) Zerosdon <- (don == 0) * maskNA } facteur = 1 if (gc < 1) { if (gc == 0) facteur = 1/2 gc = gr } if (v_distrib[e] == "bernoulli") { prov = (tau[[gr]]) %*% log(list_theta[[e]]) %*% t(tau[[gc]]) prov1m = (tau[[gr]]) %*% log(1 - list_theta[[e]]) %*% t(tau[[gc]]) return((sum(don * prov) + sum((Unmdon) * prov1m)) * facteur) } if (v_distrib[e] == "poisson") { prov = (tau[[gr]]) %*% log(list_theta[[e]]) %*% t(tau[[gc]]) prov2 = (tau[[gr]]) %*% list_theta[[e]] %*% t(tau[[gc]]) return((sum(don * prov) - sum(Unit * prov2)) * facteur) } if (v_distrib[e] == "laplace") { prov = (tau[[gr]]) %*% log(2 * list_theta[[e]]) %*% t(tau[[gc]]) prov2 = (tau[[gr]]) %*% (1/list_theta[[e]]) %*% t(tau[[gc]]) return((-sum(Unit * prov) - sum(don * prov2)) * facteur) } if (v_distrib[e] == "gaussian") { prov = 0.5 * (tau[[gr]]) %*% (log(2 * pi * list_theta[[e]]$var) + list_theta[[e]]$mean^2/list_theta[[e]]$var) %*% t(tau[[gc]]) prov2 = 0.5 * (tau[[gr]]) %*% (1/list_theta[[e]]$var) %*% t(tau[[gc]]) prov3 = (tau[[gr]]) %*% (list_theta[[e]]$mean/list_theta[[e]]$var) %*% t(tau[[gc]]) return((-sum(Unit * prov) - sum(don^2 * prov2) + sum(don * prov3)) * facteur) } if (v_distrib[e] == "ZIgaussian") { prov = 0.5 * (tau[[gr]]) %*% (log(2 * pi * list_theta[[e]]$var) + list_theta[[e]]$mean^2/list_theta[[e]]$var) %*% t(tau[[gc]]) prov2 = 0.5 * (tau[[gr]]) %*% (1/list_theta[[e]]$var) %*% t(tau[[gc]]) prov3 = (tau[[gr]]) %*% (list_theta[[e]]$mean/list_theta[[e]]$var) %*% t(tau[[gc]]) P1 <- sum((-Unit * prov - don^2 * prov2 + don * prov3) * (1 - Zerosdon)) prov4 = (tau[[gr]]) %*% log(list_theta[[e]]$p0 + (list_theta[[e]]$p0 == 0)) %*% t(tau[[gc]]) prov4m = (tau[[gr]]) %*% log(1 - list_theta[[e]]$p0 + (list_theta[[e]]$p0 == 1)) %*% t(tau[[gc]]) P2 <- sum(Zerosdon * prov4) + sum((1 - Zerosdon) * prov4m) return((P1 + P2) * facteur) }})
4: compLikICLInt(tau, list_theta, list_pi, matE, list_Mat, list_MaskNA, n_q, v_K, v_distrib)
5: varEMMBM(self, classif, tau = tau, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
6: dataR6$estime(list_classif_init[[l]], maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
7: FUN(X[[i]], ...)
8: lapply(X = S, FUN = FUN, ...)
9: doTryCatch(return(expr), name, parentenv, handler)
10: tryCatchOne(expr, names, parentenv, handlers[[1L]])
11: tryCatchList(expr, classes, parentenv, handlers)
12: tryCatch(expr, error = function(e) { call <- conditionCall(e) if (!is.null(call)) { if (identical(call[[1L]], quote(doTryCatch))) call <- sys.call(-4L) dcall <- deparse(call, nlines = 1L) prefix <- paste("Error in", dcall, ": ") LONG <- 75L sm <- strsplit(conditionMessage(e), "\n")[[1L]] w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w") if (is.na(w)) w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b") if (w > LONG) prefix <- paste0(prefix, "\n ") } else prefix <- "Error : " msg <- paste0(prefix, conditionMessage(e), "\n") .Internal(seterrmessage(msg[1L])) if (!silent && isTRUE(getOption("show.error.messages"))) { cat(msg, file = outFile) .Internal(printDeferredWarnings()) } invisible(structure(msg, class = "try-error", condition = e))})
13: try(lapply(X = S, FUN = FUN, ...), silent = TRUE)
14: sendMaster(try(lapply(X = S, FUN = FUN, ...), silent = TRUE))
15: FUN(X[[i]], ...)
16: lapply(seq_len(cores), inner.do)
17: mclapply(X, FUN, ..., mc.cores = mc.cores, mc.preschedule = mc.preschedule, mc.set.seed = mc.set.seed, mc.cleanup = mc.cleanup, mc.allow.recursive = mc.allow.recursive)
18: pbmcapply::pbmclapply(1:L, function(l) { estim.c.l <- dataR6$estime(list_classif_init[[l]], maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)}, mc.cores = nbCores)
19: searchKQ(dataR6 = self, classifInit = classifInit, pastICL = pastICL, Kmin = Kmin, Kmax = Kmax, nbCores = nbCores, verbose = verbose, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
20: dataR6$searchNbClusters(classifInit, Kmin = v_Kmin, Kmax = v_Kmax, pastICL = c(), verbose = verbose, nbCores = nbCores, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
21: GREMLINS::multipartiteBM(list_Net = listNetG, v_distrib = vdistrib, namesFG = namesFG, v_Kmin = v_Kmin, v_Kmax = v_Kmax, v_Kinit = NULL, initBM = initBM, keep = TRUE, verbose = verbose, nbCores = nbCores, maxiterVE = maxiterVE, maxiterVEM = maxiterVEM)
22: super$optimize(estimOptions)
23: myMultiplexFitindep$optimize(estimOptions = currentOptions)
24: eval(code, test_env)
25: eval(code, test_env)
26: withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt)
27: doTryCatch(return(expr), name, parentenv, handler)
28: tryCatchOne(expr, names, parentenv, handlers[[1L]])
29: tryCatchList(expr, classes, parentenv, handlers)
30: tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal)
31: doWithOneRestart(return(expr), restart)
32: withOneRestart(expr, restarts[[1L]])
33: withRestarts(tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal), end_test = function() { })
34: test_code(code, parent.frame())
35: test_that("Inference for Multiplex networks", { if (Sys.info()["sysname"] != "Windows") { set.seed(2) npc <- 30 Q <- 3 n <- npc * Q Z <- diag(Q) %x% matrix(1, npc, 1) P <- matrix(runif(Q * Q), Q, Q) A <- 1 * (matrix(runif(n * n), n, n) < Z %*% P %*% t(Z)) type <- "simple" netA <- defineSBM(A, "bernoulli", type = "simple", directed = TRUE, dimLabels = c("Actor")) B <- 1 * (matrix(runif(n * n), n, n) < Z %*% P %*% t(Z)) netB <- defineSBM(B, "bernoulli", type = "simple", dimLabels = c("Actor")) myMultiplex <- MultiplexSBM_fit$new(list(netA, netB)) netC <- defineSBM(B, "poisson", type = "simple", dimLabels = c("Actor")) expect_equal(myMultiplex$directed, c(TRUE, TRUE)) expect_equal(myMultiplex$nbNetworks, 2) expect_equal(myMultiplex$dependentNetwork, FALSE) expect_equal(MultiplexSBM_fit$new(list(netA, netB), TRUE)$dependentNetwork, TRUE) expect_error(MultiplexSBM_fit$new(list(netA, netC), TRUE)) expect_error(MultiplexSBM_fit$new(list(netA, netB, netB), TRUE)) currentOptions <- list(verbosity = 1, nbBlocksRange = list(c(1, 10)), nbCores = 2, maxiterVE = 100, maxiterVEM = 100, initBM = TRUE) myMultiplexFitindep <- MultiplexSBM_fit$new(list(netA, netB, netC)) myMultiplexFitindep$optimize(estimOptions = currentOptions) expect_equal(length(myMultiplexFitindep$connectParam), 3) myMultiplexFitdep <- MultiplexSBM_fit$new(list(netA, netB), dependentNet = TRUE) currentOptions <- list(verbosity = 3, plot = TRUE, explorFactor = 1.5, nbBlocksRange = c(4, Inf), nbCores = 2, fast = TRUE) myMultiplexFitdep$optimize(estimOptions = currentOptions) myMultiplexFitdep$probMemberships expect_equal(class(myMultiplexFitdep$memberships), "list") expect_equal(length(myMultiplexFitdep$connectParam), 4) expect_equal(myMultiplexFitdep$dependentNetwork, TRUE) set.seed(2) npc1 <- 30 npc2 <- 20 Q1 <- 2 Q2 <- 3 n1 <- npc1 * Q1 n2 <- npc2 * Q2 Z1 <- diag(Q1) %x% matrix(1, npc1, 1) Z2 <- diag(Q2) %x% matrix(1, npc2, 1) P <- matrix(runif(Q1 * Q2), Q1, Q2) A <- 1 * (matrix(runif(n1 * n2), n1, n2) < Z1 %*% P %*% t(Z2)) netA <- defineSBM(A, "bernoulli", type = "bipartite", directed = TRUE, dimLabels = c("Actor", "Object")) B <- 1 * (matrix(runif(n1 * n2), n1, n2) < Z1 %*% P %*% t(Z2)) netB <- defineSBM(B, "bernoulli", type = "bipartite", dimLabels = c("Actor", "Object")) myMultiplexFitindep <- MultiplexSBM_fit$new(list(netA, netB)) currentOptions <- list(verbosity = 1, nbBlocksRange = list(c(1, 10), c(1, 10)), nbCores = 2, maxiterVE = 100, maxiterVEM = 100, initBM = FALSE) names(currentOptions$nbBlocksRange) = c("Actor", "Object") myMultiplexFitindep$optimize(currentOptions) expect_equal(length(myMultiplexFitindep$connectParam), 2) }})
36: eval(code, test_env)
37: eval(code, test_env)
38: withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt)
39: doTryCatch(return(expr), name, parentenv, handler)
40: tryCatchOne(expr, names, parentenv, handlers[[1L]])
41: tryCatchList(expr, classes, parentenv, handlers)
42: tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal)
43: doWithOneRestart(return(expr), restart)
44: withOneRestart(expr, restarts[[1L]])
45: withRestarts(tryCatch(withCallingHandlers({ eval(code, test_env) new_expectations <- the$test_expectations > starting_expectations if (snapshot_skipped) { skip("On CRAN") } else if (!new_expectations && skip_on_empty) { skip_empty() }}, expectation = handle_expectation, packageNotFoundError = function(e) { if (on_cran()) { skip(paste0("{", e$package, "} is not installed.")) }}, snapshot_on_cran = function(cnd) { snapshot_skipped <<- TRUE invokeRestart("muffle_cran_snapshot")}, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error, interrupt = handle_interrupt), error = handle_fatal), end_test = function() { })
46: test_code(code = exprs, env = env, reporter = get_reporter() %||% StopReporter$new())
47: source_file(path, env = env(env), desc = desc, shuffle = shuffle, error_call = error_call)
48: FUN(X[[i]], ...)
49: lapply(test_paths, test_one_file, env = env, desc = desc, shuffle = shuffle, error_call = error_call)
50: doTryCatch(return(expr), name, parentenv, handler)
51: tryCatchOne(expr, names, parentenv, handlers[[1L]])
52: tryCatchList(expr, classes, parentenv, handlers)
53: tryCatch(code, testthat_abort_reporter = function(cnd) { cat(conditionMessage(cnd), "\n") NULL})
54: with_reporter(reporters$multi, lapply(test_paths, test_one_file, env = env, desc = desc, shuffle = shuffle, error_call = error_call))
55: test_files_serial(test_dir = test_dir, test_package = test_package, test_paths = test_paths, load_helpers = load_helpers, reporter = reporter, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, desc = desc, load_package = load_package, shuffle = shuffle, error_call = error_call)
56: test_files(test_dir = path, test_paths = test_paths, test_package = package, reporter = reporter, load_helpers = load_helpers, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, load_package = load_package, parallel = parallel, shuffle = shuffle)
57: test_dir("testthat", package = package, reporter = reporter, ..., load_package = "installed")
58: test_check("sbm")
An irrecoverable exception occurred. R is aborting now ...
Saving _problems/test-MultiplexSBM_fit-36.R
[1] "use of sampleMultipartite"
[1] "use of sampleMultipartite"
[ FAIL 2 | WARN 2 | SKIP 0 | PASS 1026 ]
══ Failed tests ════════════════════════════════════════════════════════════════
── Error ('test-MultipartiteSBM.R:47:5'): initializing Multipartite SBM works ──
Error in `which(sapply(R, function(u) { u$convergence }))`: argument to 'which' is not logical
Backtrace:
▆
1. └─myMBM$optimize(estimOptions) at test-MultipartiteSBM.R:47:5
2. └─GREMLINS::multipartiteBM(...)
3. └─dataR6$searchNbClusters(...)
4. └─GREMLINS:::searchKQ(...)
5. └─dataR6$cleanResults(allEstim)
6. └─GREMLINS:::cleanEstim(self, R)
7. └─base::which(...)
── Error ('test-MultiplexSBM_fit.R:36:5'): Inference for Multiplex networks ────
Error in `which(sapply(R, function(u) { u$convergence }))`: argument to 'which' is not logical
Backtrace:
▆
1. └─myMultiplexFitindep$optimize(estimOptions = currentOptions) at test-MultiplexSBM_fit.R:36:5
2. └─super$optimize(estimOptions)
3. └─GREMLINS::multipartiteBM(...)
4. └─dataR6$searchNbClusters(...)
5. └─GREMLINS:::searchKQ(...)
6. └─dataR6$cleanResults(allEstim)
7. └─GREMLINS:::cleanEstim(self, R)
8. └─base::which(...)
[ FAIL 2 | WARN 2 | SKIP 0 | PASS 1026 ]
Error:
! Test failures.
Execution halted
OK
r-devel-windows-x86_64
*
OK
r-oldrel-macos-arm64
*
OK
r-oldrel-macos-x86_64
*
OK
r-oldrel-windows-x86_64
*
OK
r-patched-linux-x86_64
*
OK
r-release-linux-x86_64
*
OK
r-release-macos-arm64
*
OK
r-release-macos-x86_64
*
OK
r-release-windows-x86_64
*
Check History
ERROR 13 OK · 0 NOTE · 0 WARNING · 1 ERROR · 0 FAILURE Mar 9, 2026
ERROR
r-devel-macos-arm64
tests
Running ‘spelling.R’ [0s/0s]
Running ‘testthat.R’ [18s/14s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(sbm)
> library(aricode)
>
> test_check("sbm")
Reverse Dependencies (2)
depends
imports
Dependency Network
Version History
new
0.4.7
Mar 9, 2026