tests/testthat/test_combinedmodels.R

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

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

test_that("Combined models sbm and gmm", {
  N <- 500
  K <- 10
  pi <- rep(1 / K, K)
  mu <- diag(rep(1 / 5, K))
  sbm <- rsbm(N, pi, mu)
  gmm <- do.call(cbind, lapply(1:K, function(x) {
    rnorm(N, 20 * runif(1) - 10)
  }))
  Xnodes <- as.matrix(gmm[cbind(1:N, sbm$cl)])

  Xinput <- list(graph = sbm$x, Xnodes = Xnodes)
  Mtt <- CombinedModels(models = list(graph = SbmPrior(), Xnodes = GmmPrior()))
  sol <- greed(Xinput, model = Mtt)
  expect_equal(sol@K, K)
  solc <- cut(sol, 8)
  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(plot(extractSubModel(solc, "Xnodes")), "gtable"))
  expect_true(is.ggplot(plot(extractSubModel(solc, "graph"))))
})


test_that("Combined models multsbm and gmm", {
  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)
  gmm <- do.call(cbind, lapply(1:K, function(x) {
    rnorm(N, 20 * runif(1) - 10)
  }))
  Xnodes <- as.matrix(gmm[cbind(1:N, multsbm$cl)])

  Xinput <- list(graph = multsbm$x, Xnodes = Xnodes)
  Mtt <- CombinedModels(models = list(graph = MultSbmPrior(), Xnodes = GmmPrior()))
  sol <- greed(Xinput, model = Mtt)
  expect_equal(sol@K, K)
  solc <- cut(sol, 2)
  expect_true(is.ggplot(plot(sol, type = "tree")))
  expect_true(is.ggplot(plot(sol, type = "path")))
  expect_true(is.ggplot(plot(sol, type = "front")))
  expect_true(is(plot(extractSubModel(sol, "Xnodes")), "gtable"))
  expect_true(is.ggplot(plot(extractSubModel(sol, "graph"))))
})

test_that("Combined models mom and gmm", {
  N <- 200
  K <- 4
  pi <- rep(1 / K, K)
  mu <- cbind(diag(rep(5, K)), matrix(0, K, 20)) + matrix(runif(K * (20 + K)), K, 20 + K)
  mm <- rmm(N, pi, mu, 30)
  gmm <- do.call(cbind, lapply(1:K, function(x) {
    rnorm(N, 20 * runif(1) - 10)
  }))
  Xnodes <- as.matrix(gmm[cbind(1:N, mm$cl)])
  Xinput <- list(mom = mm$x, Xnodes = Xnodes)
  Mtt <- CombinedModels(models = list(mom = MoMPrior(), Xnodes = GmmPrior()))
  sol <- greed(Xinput, model = Mtt)
  expect_equal(sol@K, K)
  solc <- cut(sol, 2)
  expect_true(is.ggplot(plot(sol, type = "tree")))
  expect_true(is.ggplot(plot(sol, type = "path")))
  expect_true(is.ggplot(plot(sol, type = "front")))
  expect_true(is(plot(extractSubModel(sol, "Xnodes")), "gtable"))
  expect_true(is.ggplot(plot(extractSubModel(sol, "mom"))))
})

test_that("Combined models lca and gmm", {
  N <- 500
  theta <- list(
    matrix(c(0.1, 0.9, 0.9, 0.1, 0.8, 0.2, 0.05, 0.95), ncol = 2, byrow = TRUE),
    matrix(c(0.95, 0.05, 0.3, 0.7, 0.05, 0.95, 0.05, 0.95), ncol = 2, byrow = TRUE),
    matrix(c(0.95, 0.04, 0.01, 0.9, 0.09, 0.01, 0.01, 0.01, 0.98, 0.9, 0.05, 0.05), ncol = 3, byrow = TRUE),
    matrix(c(1, 0, 0, 1, 1, 0, 0, 1), ncol = 2, byrow = TRUE)
  )
  lca.data <- rlca(N, rep(1 / 4, 4), theta)
  K <- 4
  gmm <- do.call(cbind, lapply(1:K, function(x) {
    rnorm(N, 20 * runif(1) - 10)
  }))
  Xnodes <- as.matrix(gmm[cbind(1:N, lca.data$cl)])
  Xinput <- list(lca = lca.data$x, Xnodes = Xnodes)
  Mtt <- CombinedModels(models = list(lca = LcaPrior(), Xnodes = GmmPrior()))
  sol <- greed(Xinput, model = Mtt)
  solc <- cut(sol, 2)
  expect_true(is.ggplot(plot(sol, type = "tree")))
  expect_true(is.ggplot(plot(sol, type = "path")))
  expect_true(is.ggplot(plot(sol, type = "front")))
  expect_true(is(plot(extractSubModel(sol, "Xnodes")), "gtable"))
  expect_true(is(plot(extractSubModel(sol, "lca")), "gtable"))
})

test_that("Combined models lca and diaggmm", {
  N <- 500
  theta <- list(
    matrix(c(0.1, 0.9, 0.9, 0.1, 0.8, 0.2, 0.05, 0.95), ncol = 2, byrow = TRUE),
    matrix(c(0.95, 0.05, 0.3, 0.7, 0.05, 0.95, 0.05, 0.95), ncol = 2, byrow = TRUE),
    matrix(c(0.95, 0.04, 0.01, 0.9, 0.09, 0.01, 0.01, 0.01, 0.98, 0.9, 0.05, 0.05), ncol = 3, byrow = TRUE),
    matrix(c(1, 0, 0, 1, 1, 0, 0, 1), ncol = 2, byrow = TRUE)
  )
  lca.data <- rlca(N, rep(1 / 4, 4), theta)
  K <- 4
  gmm <- do.call(cbind, lapply(1:K, function(x) {
    rnorm(N, 20 * runif(1) - 10)
  }))
  Xnodes <- as.matrix(gmm[cbind(1:N, lca.data$cl)])
  Xinput <- list(lca = lca.data$x, Xnodes = Xnodes)
  Mtt <- CombinedModels(models = list(lca = LcaPrior(), Xnodes = DiagGmmPrior()))
  sol <- greed(Xinput, model = Mtt)
  expect_equal(sol@K, K)
  solc <- cut(sol, 2)
  expect_true(is.ggplot(plot(sol, type = "tree")))
  expect_true(is.ggplot(plot(sol, type = "path")))
  expect_true(is.ggplot(plot(sol, type = "front")))
  expect_true(is(plot(extractSubModel(sol, "Xnodes")), "gtable"))
  expect_true(is(plot(extractSubModel(sol, "lca")), "gtable"))
})