tests/testthat/test_multsbm.R

In greed: Clustering and Model Selection with the Integrated Classification Likelihood

context("MULTSBM test")
library(greed)
library(ggplot2)
set.seed(1234)

test_that("MULTSBM sim", {
  N <- 100
  K <- 3
  pi <- rep(1 / K, K)
  mu <- array(dim = c(K, K, 3))
  mu[, , 1] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[1, 1, 1] <- runif(1) * 0.005
  mu[, , 2] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[2, 2, 1] <- runif(1) * 0.005
  mu[, , 3] <- 1 - mu[, , 1] - mu[, , 2]
  lambda <- 10
  multsbm <- rmultsbm(N, pi, mu, 10)
  expect_equal(dim(multsbm$x)[1], N)
  expect_equal(dim(multsbm$x)[2], N)
  expect_equal(length(multsbm$cl), N)
  expect_gte(min(multsbm$cl), 1)
  expect_lte(max(multsbm$cl), K)
  model <- MultSbm()
  data <- greed:::preprocess(model, multsbm$x)
  i <- sample(100, 1)
  oldcl <- multsbm$cl[i]
  newcl <- sample(setdiff(1:K, oldcl), 1)
  expect_lte(greed:::test_swap(model, data, multsbm$cl, i, newcl), 10^-6)
  expect_lte(greed:::test_merge(model, data, multsbm$cl, oldcl, newcl), 10^-6)
  expect_lte(max(abs(greed:::test_merge_correction(model, data, multsbm$cl, oldcl, newcl))), 10^-6)
  # undirected 
  multsbm$x[, , 1] <- matrix(tril(multsbm$x[, , 1]) + t(tril(multsbm$x[, , 1])))
  diag(multsbm$x[, , 1]) <- 0
  multsbm$x[, , 2] <- matrix(tril(multsbm$x[, , 2]) + t(tril(multsbm$x[, , 2])))
  diag(multsbm$x[, , 2]) <- 0
  multsbm$x[, , 3] <- matrix(tril(multsbm$x[, , 3]) + t(tril(multsbm$x[, , 3])))
  diag(multsbm$x[, , 3]) <- 0
  model <- MultSbm(type="undirected")
  data <- greed:::preprocess(model, multsbm$x)
  expect_lte(greed:::test_swap(model, data, multsbm$cl, i, newcl), 10^-6)
  expect_lte(greed:::test_merge(model, data, multsbm$cl, oldcl, newcl), 10^-6)
  expect_lte(max(abs(greed:::test_merge_correction(model, data, multsbm$cl, oldcl, newcl))), 10^-6)
})


test_that("MULTSBM hybrid directed", {
  N <- 100
  K <- 3
  pi <- rep(1 / K, K)
  mu <- array(dim = c(K, K, 3))
  mu[, , 1] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[1, 1, 1] <- runif(1) * 0.005
  mu[, , 2] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[2, 2, 1] <- runif(1) * 0.005
  mu[, , 3] <- 1 - mu[, , 1] - mu[, , 2]
  lambda <- 10
  multsbm <- rmultsbm(N, pi, mu, 10)
  sol <- greed(multsbm$x, model = MultSbm())
  expect_equal(sol@K, K)
  solc <- cut(sol, 2)
  expect_true(is.ggplot(plot(solc, type = "tree")))
  expect_true(is.ggplot(plot(solc, type = "path")))
  expect_true(is.ggplot(plot(solc, type = "front")))
  expect_true(is.ggplot(plot(solc, type = "blocks")))
  expect_true(is.ggplot(plot(solc, type = "nodelink")))
  co <- coef(sol)
  expect_true(all(dim(co$thetakl) == 3))
  expect_equal(length(co$pi), 3)
  expect_equal(sum(co$pi), 1)
  expect_true(all(rowSums(co$thetakl, 2) == 3))
})

test_that("MULTSBM seed directed", {
  N <- 100
  K <- 3
  pi <- rep(1 / K, K)
  mu <- array(dim = c(K, K, 3))
  mu[, , 1] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[1, 1, 1] <- runif(1) * 0.005
  mu[, , 2] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[2, 2, 1] <- runif(1) * 0.005
  mu[, , 3] <- 1 - mu[, , 1] - mu[, , 2]
  lambda <- 10
  multsbm <- rmultsbm(N, pi, mu, 10)
  sol <- greed(multsbm$x, model = MultSbm(), alg = Seed())
  expect_gte(sol@K, K - 2)
  expect_lte(sol@K, K + 2)
  solc <- cut(sol, 2)
  expect_true(is.ggplot(plot(solc, type = "tree")))
  expect_true(is.ggplot(plot(solc, type = "path")))
  expect_true(is.ggplot(plot(solc, type = "front")))
  expect_true(is.ggplot(plot(solc, type = "blocks")))
  expect_true(is.ggplot(plot(solc, type = "nodelink")))
})




test_that("MULTSBM sim", {
  N <- 100
  K <- 3
  pi <- rep(1 / K, K)
  mu <- array(dim = c(K, K, 3))
  mu[, , 1] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[1, 1, 1] <- runif(1) * 0.005
  mu[, , 2] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[2, 2, 1] <- runif(1) * 0.005
  mu[, , 3] <- 1 - mu[, , 1] - mu[, , 2]
  lambda <- 10
  multsbm <- rmultsbm(N, pi, mu, 10)
  expect_equal(dim(multsbm$x)[1], N)
  expect_equal(dim(multsbm$x)[2], N)
  expect_equal(length(multsbm$cl), N)
  expect_gte(min(multsbm$cl), 1)
  expect_lte(max(multsbm$cl), K)
})


test_that("MULTSBM hybrid undirected", {
  N <- 100
  K <- 3
  pi <- rep(1 / K, K)
  mu <- array(dim = c(K, K, 3))
  mu[, , 1] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[1, 1, 1] <- runif(1) * 0.005
  mu[, , 2] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[2, 2, 1] <- runif(1) * 0.005
  mu[, , 3] <- 1 - mu[, , 1] - mu[, , 2]
  lambda <- 10
  multsbm <- rmultsbm(N, pi, mu, 10)
  multsbm$x[, , 1] <- matrix(tril(multsbm$x[, , 1]) + t(tril(multsbm$x[, , 1])))
  diag(multsbm$x[, , 1]) <- 0
  multsbm$x[, , 2] <- matrix(tril(multsbm$x[, , 2]) + t(tril(multsbm$x[, , 2])))
  diag(multsbm$x[, , 2]) <- 0
  multsbm$x[, , 3] <- matrix(tril(multsbm$x[, , 3]) + t(tril(multsbm$x[, , 3])))
  diag(multsbm$x[, , 3]) <- 0
  sol <- greed(multsbm$x, model = MultSbm(type = "undirected"))
  expect_equal(sol@K, K)
  solc <- cut(sol, 2)
  expect_true(is.ggplot(plot(solc, type = "tree")))
  expect_true(is.ggplot(plot(solc, type = "path")))
  expect_true(is.ggplot(plot(solc, type = "front")))
  expect_true(is.ggplot(plot(solc, type = "blocks")))
  expect_true(is.ggplot(plot(solc, type = "nodelink")))
  co <- coef(sol)
  expect_true(all(dim(co$thetakl) == 3))
  expect_equal(length(co$pi), 3)
  expect_equal(sum(co$pi), 1)
  expect_true(all(rowSums(co$thetakl, 2) == 3))
})

test_that("MULTSBM seed undirected", {
  N <- 100
  K <- 3
  pi <- rep(1 / K, K)
  mu <- array(dim = c(K, K, 3))
  mu[, , 1] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[1, 1, 1] <- runif(1) * 0.005
  mu[, , 2] <- diag(rep(1 / 5, K)) + runif(K^2) * 0.005
  mu[2, 2, 1] <- runif(1) * 0.005
  mu[, , 3] <- 1 - mu[, , 1] - mu[, , 2]
  lambda <- 10
  multsbm <- rmultsbm(N, pi, mu, 10)
  multsbm$x[, , 1] <- matrix(tril(multsbm$x[, , 1]) + t(tril(multsbm$x[, , 1])))
  diag(multsbm$x[, , 1]) <- 0
  multsbm$x[, , 2] <- matrix(tril(multsbm$x[, , 2]) + t(tril(multsbm$x[, , 2])))
  diag(multsbm$x[, , 2]) <- 0
  multsbm$x[, , 3] <- matrix(tril(multsbm$x[, , 3]) + t(tril(multsbm$x[, , 3])))
  diag(multsbm$x[, , 3]) <- 0

  sol <- greed(multsbm$x, model = MultSbm(type = "undirected"), alg = Seed())
  expect_gte(sol@K, K - 2)
  expect_lte(sol@K, K + 2)
  solc <- cut(sol, 2)
  expect_true(is.ggplot(plot(solc, type = "tree")))
  expect_true(is.ggplot(plot(solc, type = "path")))
  expect_true(is.ggplot(plot(solc, type = "front")))
  expect_true(is.ggplot(plot(solc, type = "blocks")))
  expect_true(is.ggplot(plot(solc, type = "nodelink")))
})