tests/testthat/test-disco-method-disco.R

In causalDisco: Tools for Causal Discovery on Observational Data

# ──────────────────────────────────────────────────────────────────────────────
# disco_method()
# ──────────────────────────────────────────────────────────────────────────────

test_that("disco_method builds a closure with correct classes and private env", {
  # fake builder that records the knowledge it was called with
  make_builder <- function() {
    function(k) {
      e <- new.env(parent = emptyenv())
      e$k <- k
      list(
        set_knowledge = function(knowledge) {
          e$k <- knowledge
          invisible(NULL)
        },
        run = function(data) {
          list(data = data, knowledge = e$k)
        }
      )
    }
  }

  builder <- make_builder()
  m <- disco_method(builder, method_class = "pc")

  # classes
  expect_s3_class(m, c("pc", "disco_method", "function"))
  # private env has builder and NULL knowledge
  env <- environment(m)
  expect_true(is.function(env$builder))
  expect_null(env$knowledge)

  # data guard
  expect_error(
    m(1:3),
    "`data` must be a data frame or a `mids` object.",
    fixed = TRUE
  )

  # when called, passes env$knowledge (NULL) to builder and returns runner$run()
  my_df <- data.frame(x = 1:3, y = 3:1)
  out <- m(my_df)
  expect_type(out, "list")
  expect_identical(out$knowledge, NULL)
  expect_identical(out$data, my_df)
})

# ──────────────────────────────────────────────────────────────────────────────
# set_knowledge()
# ──────────────────────────────────────────────────────────────────────────────

test_that("set_knowledge.disco_method returns a new method that injects knowledge", {
  # fake builder with capturable knowledge flow
  make_builder <- function() {
    function(k) {
      e <- new.env(parent = emptyenv())
      e$k <- k
      list(
        set_knowledge = function(knowledge) {
          e$k <- knowledge
          invisible(NULL)
        },
        run = function(data) {
          list(data = data, knowledge = e$k)
        }
      )
    }
  }

  builder <- make_builder()
  m <- disco_method(builder, "pc")

  # original method remains knowledge-free
  my_df <- data.frame(a = 1:2, b = 2:1)
  out0 <- m(my_df)
  expect_null(out0$knowledge)

  # set knowledge -> returns a new disco_method preserving class
  kn <- list(tag = "my-knowledge")
  m2 <- set_knowledge(m, kn)
  expect_s3_class(m2, c("pc", "disco_method", "function"))

  # the new method injects knowledge via runner$set_knowledge()
  out1 <- m2(my_df)
  expect_identical(out1$knowledge, kn)

  # the original method is unchanged (immutability check)
  out2 <- m(my_df)
  expect_null(out2$knowledge)
})

test_that("set_knowledge wrapped method still validates data.frame input", {
  # mocking a builder
  builder <- function(k) {
    e <- new.env(parent = emptyenv())
    e$k <- k
    list(
      set_knowledge = function(knowledge) {
        e$k <- knowledge
        invisible(NULL)
      },
      run = function(data) {
        list(data = data, knowledge = e$k)
      }
    )
  }
  m <- disco_method(builder, "pc")
  m2 <- set_knowledge(m, list(foo = "bar"))

  expect_error(
    m2(1:5),
    "`data` must be a data frame or a `mids` object.",
    fixed = TRUE
  )
})