tests/testthat/test-misc.R

In causalDisco: Tools for Causal Discovery on Observational Data

# ──────────────────────────────────────────────────────────────────────────────
# as.graphNEL
# ──────────────────────────────────────────────────────────────────────────────

test_that("as.graphNEL drops tamat class", {
  m <- matrix(c(0, 1, 0, 0), nrow = 2, byrow = TRUE)
  rownames(m) <- colnames(m) <- c("A", "B")
  attr(m, "tamat_type") <- "pdag"
  class(m) <- c("tamat", "matrix")

  g <- as.graphNEL(m)
  expect_s4_class(g, "graphNEL")

  mat_from_g <- methods::as(g, "matrix")
  expect_equal(mat_from_g, t(unclass(m)), ignore_attr = TRUE)
})

# ──────────────────────────────────────────────────────────────────────────────
# translate_custom_test_to_bnlearn
# ──────────────────────────────────────────────────────────────────────────────

test_that("wraps function returning only p-value", {
  f <- function(x, y, data) {
    0.05
  }

  wrapped <- translate_custom_test_to_bnlearn(f)
  res <- wrapped("A", "B", NULL, data.frame(A = 1, B = 2))

  expect_type(res, "double")
  expect_length(res, 2)
  expect_true(is.na(res[1]))
  expect_equal(res[2], 0.05)
})

test_that("passes through statistic and p-value unchanged", {
  f <- function(x, y, data) {
    c(1.23, 0.04)
  }

  wrapped <- translate_custom_test_to_bnlearn(f)
  res <- wrapped("A", "B", NULL, data.frame(A = 1, B = 2))

  expect_equal(res, c(1.23, 0.04))
})

test_that("maps conditioning_set correctly", {
  f <- function(x, y, conditioning_set, data) {
    expect_equal(conditioning_set, c("Z1", "Z2"))
    0.1
  }

  wrapped <- translate_custom_test_to_bnlearn(f)
  wrapped("A", "B", c("Z1", "Z2"), data.frame())
})

test_that("maps suff_stat instead of data", {
  f <- function(x, y, suff_stat) {
    expect_true(is.data.frame(suff_stat))
    0.2
  }

  wrapped <- translate_custom_test_to_bnlearn(f)
  wrapped("A", "B", NULL, data.frame(A = 1))
})

test_that("uses z if user function expects z", {
  f <- function(x, y, z) {
    expect_equal(z, "Z")
    0.3
  }

  wrapped <- translate_custom_test_to_bnlearn(f)
  wrapped("A", "B", "Z", data.frame())
})

test_that("passes args when supported", {
  f <- function(x, y, data, args) {
    expect_equal(args$alpha, 0.05)
    0.01
  }

  wrapped <- translate_custom_test_to_bnlearn(f)
  wrapped("A", "B", NULL, data.frame(), args = list(alpha = 0.05))
})

test_that("does not pass args when not supported", {
  f <- function(x, y, data) {
    0.02
  }

  wrapped <- translate_custom_test_to_bnlearn(f)

  expect_silent(
    wrapped("A", "B", NULL, data.frame(), args = list(alpha = 0.05))
  )
})

test_that("errors on invalid return length", {
  f <- function(x, y, data) {
    c(1, 2, 3)
  }

  wrapped <- translate_custom_test_to_bnlearn(f)

  expect_error(
    wrapped("A", "B", NULL, data.frame()),
    "must return"
  )
})

test_that("works with minimal function signature", {
  f <- function(x, y) {
    0.5
  }

  wrapped <- translate_custom_test_to_bnlearn(f)
  res <- wrapped("A", "B", "Z", data.frame())

  expect_length(res, 2)
  expect_equal(res[2], 0.5)
})