tests/testthat/test-knowledge-manipulation.R

In causalDisco: Tools for Causal Discovery on Observational Data

# ──────────────────────────────────────────────────────────────────────────────
# reorder_tiers()
# ──────────────────────────────────────────────────────────────────────────────

test_that("reorder_tiers() works with complete permutations", {
  kn <- knowledge(tier(One ~ V1, Two ~ V2, Three ~ V3))

  # by label, character
  expect_equal(
    reorder_tiers(kn, c("One", "Three", "Two"))$tiers,
    tiers_tbl("One", "Three", "Two")
  )

  # by label, bare symbols
  expect_equal(
    reorder_tiers(kn, c(One, Three, Two))$tiers,
    tiers_tbl("One", "Three", "Two")
  )

  # by index
  expect_equal(
    reorder_tiers(kn, c(1, 3, 2), by_index = TRUE)$tiers,
    tiers_tbl("One", "Three", "Two")
  )
})

test_that("reorder_tiers() errors on incomplete or duplicated permutations", {
  kn <- knowledge(tier(One ~ V1, Two ~ V2, Three ~ V3))

  expect_error(
    reorder_tiers(kn, c("One", "Two")),
    "`order` must list every existing tier exactly once",
    fixed = TRUE
  )
  expect_error(
    reorder_tiers(kn, c("One", "One", "Two")),
    "`order` must list every existing tier exactly once",
    fixed = TRUE
  )
  expect_error(
    reorder_tiers(kn, c(1, 1, 2), by_index = TRUE),
    "`order` must be a permutation of 1:3 when `by_index = TRUE`.",
    fixed = TRUE
  )
})

test_that("reorder_tiers() handles numeric, character and bad elements", {
  kn_num <- knowledge(
    tibble::tibble(A = 1, B = 2),
    tier(1 ~ A),
    tier(2 ~ B)
  )

  kn_chr <- knowledge(
    tibble::tibble(X = 1, Y = 2),
    tier("a" ~ X),
    tier("b" ~ Y)
  )
  kn_num2 <- reorder_tiers(kn_num, c(2, 1)) # numeric literals

  expect_equal(kn_num2$tiers$label, c("2", "1"))

  kn_chr2 <- reorder_tiers(kn_chr, c("b", "a")) # quoted strings

  expect_equal(kn_chr2$tiers$label, c("b", "a"))

  # 1:2 is a language call, so as_label1() must raise the custom error
  expect_error(
    reorder_tiers(kn_chr, c(a, 1:2)), # 'a' is fine, 1:2 is not
    "`order` contains an unsupported element",
    fixed = TRUE
  )
})

# ──────────────────────────────────────────────────────────────────────────────
# reposition_tier()
# ──────────────────────────────────────────────────────────────────────────────

test_that("reposition_tier() moves a tier before/after another", {
  kn <- knowledge(tier(One ~ V1, Two ~ V2, Three ~ V3))

  expect_equal(
    reposition_tier(kn, Three, before = Two)$tiers,
    tiers_tbl("One", "Three", "Two")
  )
  expect_equal(
    reposition_tier(kn, "Three", before = "Two")$tiers,
    tiers_tbl("One", "Three", "Two")
  )
  expect_equal(
    reposition_tier(kn, Three, after = One)$tiers,
    tiers_tbl("One", "Three", "Two")
  )
  expect_equal(
    reposition_tier(kn, "Three", after = "One")$tiers,
    tiers_tbl("One", "Three", "Two")
  )

  # by index
  expect_equal(
    reposition_tier(kn, 3, before = 2, by_index = TRUE)$tiers,
    tiers_tbl("One", "Three", "Two")
  )
  expect_equal(
    reposition_tier(kn, 3, after = 1, by_index = TRUE)$tiers,
    tiers_tbl("One", "Three", "Two")
  )
})

test_that("reposition_tier() validates inputs", {
  kn <- knowledge(tier(One ~ V1, Two ~ V2, Three ~ V3))

  # both before and after supplied
  expect_error(
    reposition_tier(kn, Three, before = One, after = Two),
    "exactly one of",
    fixed = TRUE
  )

  # unknown tier
  expect_error(
    reposition_tier(kn, Four, before = One),
    "does not exist",
    fixed = TRUE
  )

  # unknown anchor
  expect_error(
    reposition_tier(kn, Three, before = Four),
    "does not exist",
    fixed = TRUE
  )
})

test_that("reposition_tier() errors when no before or after is provided", {
  kn <- knowledge(tier(One ~ V1, Two ~ V2, Three ~ V3))
  expect_error(
    reposition_tier(kn, One),
    "Supply exactly one of `before` or `after`.",
    fixed = TRUE
  )
})

test_that("reposition_tier() edge cases", {
  kn <- knowledge(
    tibble::tibble(V1 = 1, V2 = 2, V3 = 3),
    tier(1 ~ V1),
    tier(2 ~ V2),
    tier(3 ~ V3)
  )

  # by_index = TRUE but anchor has length > 1
  expect_error(
    reposition_tier(kn, tier = 1, after = c(2, 3), by_index = TRUE),
    "length-1 numeric",
    fixed = TRUE
  )

  # numeric literal resolves to a character label and reorder succeeds
  kn2 <- reposition_tier(kn, tier = 2, before = 1)
  expect_equal(kn2$tiers$label, c("2", "1", "3"))

  # invalid tier reference triggers custom error
  expect_error(
    reposition_tier(kn, tier = 1:2, after = 1),
    "Tier reference .* is invalid",
    perl = TRUE
  )

  # tier identical to anchor returns object unchanged
  expect_identical(
    reposition_tier(kn, tier = 1, before = 1),
    kn
  )
})