tests/testthat/test-sequence_plot.R

In Nestimate: Network Estimation, Bootstrap, and Higher-Order Analysis

test_that("sequence_plot draws from a data.frame + hclust", {
  set.seed(1L)
  states <- c("A", "B", "C")
  seqs <- as.data.frame(matrix(sample(states, 30 * 10, replace = TRUE),
                               nrow = 30, ncol = 10))
  d    <- stats::dist(data.matrix(seqs))
  tree <- stats::hclust(d, method = "ward.D2")

  pdf(NULL); on.exit(dev.off(), add = TRUE)

  res <- sequence_plot(seqs, tree = tree)
  expect_type(res, "list")
  expect_named(res, c("ord", "codes", "palette", "levels", "sort_used"))
  expect_length(res$ord, nrow(seqs))
  expect_setequal(res$ord, seq_len(nrow(seqs)))
  expect_equal(dim(res$codes), dim(seqs))
  expect_equal(res$levels, sort(states))
})

test_that("sequence_plot accepts a net_clustering directly", {
  set.seed(2L)
  seqs <- as.data.frame(matrix(sample(c("A", "B", "C", "D"), 25 * 12,
                                      replace = TRUE), 25, 12))
  cl <- build_clusters(seqs, k = 3L, dissimilarity = "hamming",
                     method = "ward.D2")

  pdf(NULL); on.exit(dev.off(), add = TRUE)

  res <- sequence_plot(cl)
  expect_length(res$ord, nrow(seqs))
  expect_identical(res$sort_used, "net_clustering")
})

test_that("sequence_plot sort='frequency' produces a dendrogram order", {
  set.seed(3L)
  seqs <- matrix(sample(c("A", "B", "C"), 15 * 6, replace = TRUE), 15, 6)

  pdf(NULL); on.exit(dev.off(), add = TRUE)

  res <- sequence_plot(seqs, sort = "frequency")
  expect_setequal(res$ord, seq_len(nrow(seqs)))
  expect_identical(res$sort_used, "frequency")
})

test_that("sequence_plot sort='start' sorts lexicographically forward", {
  seqs <- rbind(c("A", "B", "C"),
                c("B", "A", "A"),
                c("A", "A", "B"),
                c("B", "B", "A"))

  pdf(NULL); on.exit(dev.off(), add = TRUE)

  res <- sequence_plot(seqs, sort = "start", legend = "none")
  # After ordering, first column should be non-decreasing.
  first_col <- res$codes[res$ord, 1]
  expect_true(all(diff(first_col) >= 0))
  expect_identical(res$sort_used, "start")
})

test_that("sequence_plot sort='end' sorts lexicographically backward", {
  seqs <- rbind(c("A", "A", "B"),
                c("B", "B", "A"),
                c("A", "B", "A"),
                c("B", "A", "B"))

  pdf(NULL); on.exit(dev.off(), add = TRUE)

  res <- sequence_plot(seqs, sort = "end", legend = "none")
  last_col <- res$codes[res$ord, ncol(seqs)]
  expect_true(all(diff(last_col) >= 0))
})

test_that("sequence_plot routes distance sorts through build_clusters", {
  set.seed(4L)
  seqs <- matrix(sample(c("A", "B", "C"), 20 * 8, replace = TRUE), 20, 8)

  pdf(NULL); on.exit(dev.off(), add = TRUE)

  for (metric in c("hamming", "lcs", "lv", "osa", "dl",
                   "qgram", "cosine", "jaccard", "jw")) {
    res <- sequence_plot(seqs, sort = metric, legend = "none")
    expect_identical(res$sort_used, metric, info = metric)
    expect_length(res$ord, nrow(seqs))
  }
})

test_that("sequence_plot preserves NA cells", {
  set.seed(5L)
  seqs <- matrix(sample(c("A", "B", "C"), 20 * 8, replace = TRUE), 20, 8)
  seqs[sample(length(seqs), 10)] <- NA

  pdf(NULL); on.exit(dev.off(), add = TRUE)

  res <- sequence_plot(seqs, sort = "start", na_color = "#FF0000")
  expect_equal(sum(is.na(res$codes)), sum(is.na(seqs)))
})

test_that("sequence_plot honours all legend_position values", {
  set.seed(6L)
  seqs <- matrix(sample(c("A", "B"), 12 * 5, replace = TRUE), 12, 5)

  pdf(NULL); on.exit(dev.off(), add = TRUE)

  for (pos in c("bottom", "right", "none")) {
    expect_silent(sequence_plot(seqs, legend = pos,
                                sort = "start"))  # no tree ⇒ exercises no-tree layout
    expect_silent(sequence_plot(seqs, legend = pos,
                                sort = "frequency"))  # tree ⇒ exercises tree layout
  }
})

test_that("sequence_plot rejects mismatched tree size", {
  seqs <- matrix(sample(c("A", "B"), 20, replace = TRUE), 10, 2)
  tree <- stats::hclust(stats::dist(matrix(stats::rnorm(16), 8)))
  expect_error(sequence_plot(seqs, tree = tree), "leaves")
})

test_that("sequence_plot rejects all-NA input", {
  seqs <- matrix(NA_character_, 5, 4)
  tree <- stats::hclust(stats::dist(matrix(stats::rnorm(10), 5)))
  expect_error(sequence_plot(seqs, tree = tree), "no non-NA values")
})

test_that("sequence_plot type='index' renders single-panel with gaps", {
  set.seed(10L)
  seqs <- matrix(sample(c("A", "B", "C"), 20 * 8, replace = TRUE), 20, 8)
  pdf(NULL); on.exit(dev.off(), add = TRUE)
  res <- sequence_plot(seqs, type = "index", row_gap = 0.2)
  expect_named(res, c("codes", "palette", "levels", "orders", "groups"))
  expect_length(res$orders, 1L)
  expect_identical(res$groups, "all")
})

test_that("sequence_plot type='index' facets by net_clustering", {
  set.seed(11L)
  seqs <- as.data.frame(matrix(sample(c("A", "B", "C"), 30 * 10,
                                      replace = TRUE), 30, 10))
  cl <- build_clusters(seqs, k = 3L, dissimilarity = "hamming",
                     method = "ward.D2")
  pdf(NULL); on.exit(dev.off(), add = TRUE)
  res <- sequence_plot(cl, type = "index")
  expect_length(res$orders, 3L)
  expect_length(res$groups, 3L)
})

test_that("sequence_plot type='distribution' dispatches to distribution_plot", {
  set.seed(12L)
  seqs <- matrix(sample(c("A", "B", "C"), 24 * 6, replace = TRUE), 24, 6)
  pdf(NULL); on.exit(dev.off(), add = TRUE)
  res <- sequence_plot(seqs, type = "distribution")
  expect_named(res, c("counts", "proportions", "levels", "palette", "groups"))
})

test_that("sequence_plot type='index' honours ncol/nrow", {
  set.seed(13L)
  seqs <- as.data.frame(matrix(sample(c("A", "B", "C", "D"), 40 * 8,
                                      replace = TRUE), 40, 8))
  cl <- build_clusters(seqs, k = 4L, dissimilarity = "hamming",
                     method = "ward.D2")
  pdf(NULL); on.exit(dev.off(), add = TRUE)
  # 4 clusters in 1x4
  expect_silent(sequence_plot(cl, type = "index", ncol = 4, nrow = 1))
  # 4 clusters in 2x2
  expect_silent(sequence_plot(cl, type = "index", ncol = 2, nrow = 2))
})