tests/testthat/test-cliques.R

In igraph/rigraph: Network Analysis and Visualization

test_that("cliques() works", {
  withr::local_seed(42)

  is_clique <- function(graph, vids) {
    s <- induced_subgraph(graph, vids)
    ecount(s) == vcount(s) * (vcount(s) - 1) / 2
  }

  gnp <- sample_gnp(100, 0.3)
  expect_equal(clique_num(gnp), 6)

  cl <- sapply(cliques(gnp, min = 6), is_clique, graph = gnp)
  lcl <- sapply(largest_cliques(gnp), is_clique, graph = gnp)
  expect_equal(cl, lcl)
  expect_equal(cl, rep(TRUE, 17))
  expect_equal(lcl, rep(TRUE, 17))

  ## To have a bit less maximal cliques, about 100-200 usually
  gnp100 <- sample_gnp(100, 0.03)
  expect_true(all(sapply(max_cliques(gnp100), is_clique, graph = gnp100)))
})

test_that("clique_size_counts() works", {
  g <- make_full_graph(5) %du% make_full_graph(3)

  expect_equal(clique_size_counts(g), c(8, 13, 11, 5, 1))
  expect_equal(clique_size_counts(g, min = 3), c(0, 0, 11, 5, 1))
  expect_equal(clique_size_counts(g, max = 4), c(8, 13, 11, 5))
  expect_equal(clique_size_counts(g, min = 2, max = 4), c(0, 13, 11, 5))

  expect_equal(clique_size_counts(g, maximal = TRUE), c(0, 0, 1, 0, 1))
  expect_equal(clique_size_counts(g, min = 3, maximal = TRUE), c(0, 0, 1, 0, 1))
  expect_equal(clique_size_counts(g, max = 4, maximal = TRUE), c(0, 0, 1))
  expect_equal(
    clique_size_counts(g, min = 2, max = 4, maximal = TRUE),
    c(0, 0, 1)
  )
})

test_that("weighted_cliques works", {
  g <- make_graph(~ A - B - C - A - D - E - F - G - H - D - F - H - E - G - D)
  weights <- c(5, 5, 5, 3, 3, 3, 3, 2)

  is_clique_weight <- function(graph, vids, min_weight) {
    s <- induced_subgraph(graph, vids)
    ecount(s) == vcount(s) * (vcount(s) - 1) / 2 &&
      sum(V(s)$weight) >= min_weight
  }

  expect_equal(
    lapply(largest_weighted_cliques(g, vertex.weights = weights), as.numeric),
    list(c(1, 2, 3))
  )

  V(g)$weight <- weights
  cl <- sapply(
    weighted_cliques(g, min.weight = 9),
    is_clique_weight,
    graph = g,
    min_weight = 9
  )
  expect_equal(cl, rep(TRUE, 14))

  karate <- make_graph("zachary")
  weights <- rep(1, vcount(karate))
  weights[c(1, 2, 3, 4, 14)] <- 3
  expect_equal(weighted_clique_num(karate, vertex.weights = weights), 15)

  V(karate)$weight <- weights * 2
  expect_equal(weighted_clique_num(karate), 30)
})

test_that("max_cliques() work", {
  withr::local_seed(42)
  gnp <- sample_gnm(1000, 1000)
  full10 <- make_full_graph(10)
  for (i in 1:10) {
    gnp <- permute(gnp, sample(vcount(gnp)))
    gnp <- gnp %u% full10
  }
  gnp <- simplify(gnp)

  mysort <- function(x) {
    xl <- sapply(x, length)
    x <- lapply(x, sort)
    xc <- sapply(x, paste, collapse = "-")
    x[order(xl, xc)]
  }

  bk4 <- function(graph, min = 0, max = Inf) {
    Gamma <- function(v) {
      neighbors(graph, v)
    }

    bkpivot <- function(PX, R) {
      P <- if (PX$PE >= PX$PS) {
        PX$PX[PX$PS:PX$PE]
      } else {
        numeric()
      }
      X <- if (PX$XE >= PX$XS) {
        PX$PX[PX$XS:PX$XE]
      } else {
        numeric()
      }
      if (length(P) == 0 && length(X) == 0) {
        if (length(R) >= min && length(R) <= max) {
          list(R)
        } else {
          list()
        }
      } else if (length(P) != 0) {
        psize <- sapply(c(P, X), function(u) {
          length(intersect(P, Gamma(u)))
        })
        u <- c(P, X)[which.max(psize)]

        pres <- list()
        for (v in setdiff(P, Gamma(u))) {
          p0 <- if (PX$PS > 1) {
            PX$PX[1:(PX$PS - 1)]
          } else {
            numeric()
          }
          p1 <- setdiff(P, Gamma(v))
          p2 <- intersect(P, Gamma(v))
          x1 <- intersect(X, Gamma(v))
          x2 <- setdiff(X, Gamma(v))
          x0 <- if (PX$XE < length(PX$PX)) {
            PX$PX[(PX$XE + 1):length(PX$PX)]
          } else {
            numeric()
          }

          newPX <- list(
            PX = c(p0, p1, p2, x1, x2, x0),
            PS = length(p0) + length(p1) + 1,
            PE = length(p0) + length(p1) + length(p2),
            XS = length(p0) + length(p1) + length(p2) + 1,
            XE = length(p0) + length(p1) + length(p2) + length(x1)
          )

          pres <- c(pres, bkpivot(newPX, c(R, v)))

          vpos <- which(PX$PX == v)
          tmp <- PX$PX[PX$PE]
          PX$PX[PX$PE] <- v
          PX$PX[vpos] <- tmp
          PX$PE <- PX$PE - 1
          PX$XS <- PX$XS - 1
          P <- if (PX$PE >= PX$PS) {
            PX$PX[PX$PS:PX$PE]
          } else {
            numeric()
          }
          X <- if (PX$XE >= PX$XS) {
            PX$PX[PX$XS:PX$XE]
          } else {
            numeric()
          }
          if (any(duplicated(PX$PX))) {
            stop("foo2")
          }
        }
        pres
      }
    }

    res <- list()
    cord <- order(coreness(graph))
    for (v in seq_along(cord)) {
      if (v != length(cord)) {
        P <- intersect(Gamma(cord[v]), cord[(v + 1):length(cord)])
      } else {
        P <- numeric()
      }
      if (v != 1) {
        X <- intersect(Gamma(cord[v]), cord[1:(v - 1)])
      } else {
        X <- numeric()
      }
      PX <- list(
        PX = c(P, X),
        PS = 1,
        PE = length(P),
        XS = length(P) + 1,
        XE = length(P) + length(X)
      )
      res <- c(res, bkpivot(PX, cord[v]))
    }
    lapply(res, as.integer)
  }

  cl1 <- mysort(bk4(gnp, min = 3))
  cl2 <- mysort(unvs(max_cliques(gnp, min = 3)))

  expect_identical(cl1, cl2)
})

test_that("max_cliques() work for subsets", {
  withr::local_seed(42)
  gnp <- sample_gnp(100, .5)

  mysort <- function(x) {
    xl <- sapply(x, length)
    x <- lapply(x, sort)
    xc <- sapply(x, paste, collapse = "-")
    x[order(xl, xc)]
  }

  cl1 <- mysort(unvs(max_cliques(gnp, min = 8)))

  c1 <- unvs(max_cliques(gnp, min = 8, subset = 1:13))
  c2 <- unvs(max_cliques(gnp, min = 8, subset = 14:100))
  cl2 <- mysort(c(c1, c2))

  expect_identical(cl1, cl2)
})

test_that("count_max_cliques works", {
  withr::local_seed(42)
  gnp <- sample_gnp(100, .5)

  cl1 <- count_max_cliques(gnp, min = 8)

  c1 <- count_max_cliques(gnp, min = 8, subset = 1:13)
  c2 <- count_max_cliques(gnp, min = 8, subset = 14:100)
  cl2 <- c1 + c2

  expect_identical(cl1, cl2)
})

test_that("ivs() works", {
  gnp <- sample_gnp(50, 0.8)
  ivs <- ivs(gnp, min = ivs_size(gnp))
  edges_iv <- sapply(seq_along(ivs), function(x) {
    ecount(induced_subgraph(gnp, ivs[[x]]))
  })
  expect_equal(unique(edges_iv), 0)
})

test_that("ivs() works, cliques of complement", {
  # 2385298846 https://github.com/igraph/rigraph/pull/1541#issuecomment-2385298846
  # that the independent vertex sets of G are
  # the same as the cliques of the complement of G (and vice versa)
  gnp <- sample_gnp(50, 0.8)
  ivs <- ivs(gnp, min = ivs_size(gnp)) %>% lapply(as.numeric)
  complement <- complementer(gnp)
  cliques <- cliques(complement, min = ivs_size(gnp)) %>% lapply(as.numeric)

  expect_equal(length(ivs), length(cliques))

  ivs_with_equivalent <- map_lgl(
    ivs,
    function(element, cliques) {
      any(map_lgl(cliques, function(x) identical(x, element)))
    },
    cliques = cliques
  )
  expect_equal(sum(ivs_with_equivalent), length(ivs))

  cliques_with_equivalent <- map_lgl(
    cliques,
    function(element, ivs) any(map_lgl(ivs, function(x) identical(x, element))),
    ivs = ivs
  )
  expect_equal(sum(cliques_with_equivalent), length(cliques))
})

test_that("largest_cliques() works", {
  adj <- matrix(1, nrow = 11, ncol = 11) - diag(11)
  g <- graph_from_adjacency_matrix(adj)
  expect_warning(
    lc <- largest_cliques(g),
    "Edge directions are ignored for maximal clique calculation"
  )
  expect_equal(lapply(unvs(lc), sort), list(1:11))
})

test_that("largest_ivs() works", {
  g <- sample_gnp(50, 0.8)
  livs <- largest_ivs(g)
  expect_equal(
    unique(sapply(livs, length)),
    ivs_size(g)
  )

  ec <- sapply(seq_along(livs), function(x) {
    ecount(induced_subgraph(g, livs[[x]]))
  })
  expect_equal(unique(ec), 0)

  expect_length(ivs(g, min = length(livs[[1]]) + 1), 0)
})

test_that("largest_cliques works", {
  g <- sample_gnp(50, 20 / 50)
  lc <- largest_cliques(g)
  expect_length(cliques(g, min = length(lc[[1]]) + 1), 0)

  lc_ring <- largest_cliques(make_ring(10))
  expect_equal(max(sapply(lc_ring, length)), 2)
})

test_that("is_clique works", {
  withr::local_seed(42)

  g <- make_full_graph(5)
  expect_true(is_clique(g, V(g)))

  g <- sample_gnp(15, 0.5)
  max_cl <- max_cliques(g)
  all_are_cliques <- all(sapply(max_cl, function(x) is_clique(g, x)))
  expect_true(all_are_cliques)
})

test_that("is_ivs works", {
  withr::local_seed(42)

  g <- make_full_bipartite_graph(5, 5)
  expect_true(is_ivs(g, V(g)[V(g)$type]))

  g <- sample_gnp(15, 0.5)
  max_ivs <- max_ivs(g)
  all_are_ivs <- all(sapply(max_ivs, function(x) is_ivs(g, x)))
  expect_true(all_are_ivs)
})

test_that("is_complete works", {
  g1 <- make_full_graph(5)
  expect_true(is_complete(g1))

  g2 <- make_full_graph(5, directed = TRUE)
  expect_true(is_complete(g1))

  g3 <- delete_edges(g2, 1)
  expect_false(is_complete(g3))

  g4 <- as_undirected(g3)
  expect_true(is_complete(g4))
})