tests/testthat/test-tetrad-search.R

In causalDisco: Tools for Causal Discovery on Observational Data

skip_if_no_tetrad()

# ──────────────────────────────────────────────────────────────────────────────
# Tetrad test setup and utility functions
# ──────────────────────────────────────────────────────────────────────────────

test_that("knowledge helper builds tiered/required/forbidden objects and casts to Tetrad", {
  data(num_data)

  kn <- make_knowledge_test_object(num_data)

  expect_true(is.list(kn))
  expect_true(all(
    c("tiered_kn", "forbidden_kn", "required_kn", "combi_kn") %in% names(kn)
  ))

  # should cast to a Java Knowledge via your package API
  tk <- as_tetrad_knowledge(kn$combi_kn)
  expect_jobj(tk)

  # TetradSearch should accept it without complaint
  ts <- TetradSearch$new()
  expect_no_condition(ts$set_knowledge(kn$combi_kn))
  expect_jobj(ts$get_knowledge())
})

test_that("Java and Tetrad JARs are ready", {
  jars <- get_tetrad_dir()
  expect_true(length(jars) > 0)
  expect_true(all(file.exists(jars)))
})


# ──────────────────────────────────────────────────────────────────────────────
# TetradSearch constructor sets defaults correctly
# ──────────────────────────────────────────────────────────────────────────────

test_that("TetradSearch constructor sets defaults correctly", {
  ts <- TetradSearch$new()

  # java-side objects exist
  expect_jobj(ts$knowledge)
  expect_jobj(ts$params)

  # everything else starts NULL
  expect_null(ts$data)
  expect_null(ts$rdata)
  expect_null(ts$score)
  expect_null(ts$test)
  expect_null(ts$mc_test)
  expect_null(ts$alg)
  expect_null(ts$java)
  expect_null(ts$result)
  expect_null(ts$bootstrap_graphs)
  expect_null(ts$mc_ind_results)
  expect_null(ts$bhat)
  expect_null(ts$unstable_bhats)
  expect_null(ts$stable_bhats)
})


# ──────────────────────────────────────────────────────────────────────────────
# Setters
# ──────────────────────────────────────────────────────────────────────────────

test_that("set_test accepts known tests and rejects unknown; use_for_mc path sets mc_test", {
  ts <- TetradSearch$new()
  expect_no_condition(ts$set_test("fisher_z", alpha = 0.05))
  expect_no_condition(ts$set_test("chi_square", use_for_mc = TRUE))
  expect_jobj(ts$mc_test)

  expect_error(
    ts$set_test("definitely_not_a_test"),
    "Unknown test type using tetrad engine"
  )
})

test_that("set_score accepts known scores and rejects unknown", {
  ts <- TetradSearch$new()
  expect_no_condition(ts$set_score("sem_bic"))
  expect_no_condition(ts$set_score("discrete_bic"))

  expect_error(
    ts$set_score("definitely_not_a_score"),
    "Unknown score type using tetrad engine"
  )
})

test_that("set_alg enforces prerequisites for score-only, test-only, and both", {
  # score-only alg requires score
  ts1 <- TetradSearch$new()
  expect_error(ts1$set_alg("fges"), "No score is set")
  ts1$set_score("sem_bic")
  expect_no_condition(ts1$set_alg("fges"))

  # test-only alg requires test
  ts2 <- TetradSearch$new()
  expect_error(ts2$set_alg("pc"), "No test is set")
  ts2$set_test("fisher_z")
  expect_no_condition(ts2$set_alg("pc"))

  # both-required alg needs both
  ts3 <- TetradSearch$new()
  ts3$set_score("discrete_bic")
  expect_error(ts3$set_alg("gfci"), "No test is set")
  ts3$set_test("chi_square")
  expect_no_condition(ts3$set_alg("gfci"))
})

test_that("set_alg warns when background knowledge is set but algorithm ignores it", {
  ts <- TetradSearch$new()
  data(num_data)
  kn <- make_knowledge_test_object(num_data)

  ts$set_score("sem_bic")
  ts$set_knowledge(kn$tiered_kn)
  expect_warning(
    ts$set_alg("restricted_boss"),
    "This algorithm does not use background knowledge"
  )
})

test_that("set_knowledge attaches and propagates to existing algorithm", {
  ts <- TetradSearch$new()
  data(num_data)
  kn <- make_knowledge_test_object(num_data)

  ts$set_score("sem_bic")
  ts$set_alg("fges")

  # set after algorithm => should propagate without error
  expect_no_condition(ts$set_knowledge(kn$tiered_kn))
  expect_jobj(ts$get_knowledge())
})

test_that("set_knowledge propagates to an already-set algorithm", {
  ts <- TetradSearch$new()
  data(num_data)
  kn <- make_knowledge_test_object(num_data)

  ts$set_score("sem_bic")
  ts$set_alg("fges") # algo first
  expect_no_condition(ts$set_knowledge(kn$tiered_kn)) # should push into alg branch
  expect_jobj(ts$get_knowledge())
})

test_that("warning about ignored knowledge only fires when knowledge is set", {
  # no knowledge -> no warning
  ts0 <- TetradSearch$new()
  ts0$set_score("sem_bic")
  expect_no_condition(ts0$set_alg("restricted_boss"))

  # with knowledge -> warning
  ts1 <- TetradSearch$new()
  data(num_data)
  kn <- make_knowledge_test_object(num_data)
  ts1$set_score("sem_bic")
  ts1$set_knowledge(kn$tiered_kn)
  expect_warning(
    ts1$set_alg("restricted_boss"),
    "This algorithm does not use background knowledge"
  )
})


test_that("set_params() accepts numeric, logical, and character values", {
  ts <- TetradSearch$new()

  # should not error; also covers the character → Java String path
  expect_no_condition(
    ts$set_params(SEED = 7, VERBOSE = FALSE, TRUNCATION_LIMIT = 3)
  )
  expect_error(
    ts$set_params(DOES_NOT_EXIST = "failure!!")
  )
})

test_that("set_verbose() forwards to params without error and errors when not bool", {
  ts <- TetradSearch$new()
  expect_no_condition(ts$set_verbose(FALSE))
  expect_no_condition(ts$set_verbose(TRUE))
  expect_error(ts$set_verbose(2))
})

test_that("set_time_lag() accepts integers and rejects non-integers or negative numbers", {
  ts <- TetradSearch$new()
  expect_no_condition(ts$set_time_lag(0))
  expect_error(ts$set_time_lag(0.5))
  expect_error(ts$set_time_lag(-1))
  expect_error(ts$set_time_lag(-0.5))
})

test_that("set_params() accepts pre-wrapped Java objects (else-branch coverage)", {
  ts <- TetradSearch$new()

  # Pass a java.lang.Boolean so it skips the R-type guards
  jbool <- rJava::.jnew("java/lang/Boolean", TRUE)

  # This must go through the `else` path:
  #   wrapped <- .jcast(value, "java/lang/Object")
  expect_no_condition(
    ts$set_params(VERBOSE = jbool)
  )

  # Also try a java.lang.Integer to hit the same path on a different key
  jint <- rJava::.jnew("java/lang/Integer", 7L)
  expect_no_condition(
    ts$set_params(SEED = jint)
  )
})

# ──────────────────────────────────────────────────────────────────────────────
# Scores, tests, and algorithms
# ──────────────────────────────────────────────────────────────────────────────

test_that("all known scores can be set without error", {
  scores <- c(
    "sem_bic",
    "ebic",
    "bdeu",
    "basis_function_bic",
    "conditional_gaussian",
    "degenerate_gaussian",
    "discrete_bic",
    "gic",
    "mag_degenerate_gaussian_bic",
    # "mixed_variable_polynomial",
    "poisson_prior",
    "zhang_shen_bound"
  )

  purrr::walk(scores, \(s) {
    ts <- TetradSearch$new()
    expect_no_condition(ts$set_score(s))
  })
})

test_that("all known tests can be set without error (and use_for_mc path sets mc_test once)", {
  tests <- c(
    "chi_square",
    "g_square",
    "basis_function_lrt",
    "probabilistic",
    "fisher_z",
    "degenerate_gaussian",
    "conditional_gaussian",
    "kci"
  )

  # plain set
  purrr::walk(tests, \(tst) {
    ts <- TetradSearch$new()
    expect_no_condition(ts$set_test(tst))
  })

  # one explicit use_for_mc=TRUE path to cover mc_test
  purrr::walk(tests, \(tst) {
    ts <- TetradSearch$new()
    expect_no_condition(ts$set_test(tst, use_for_mc = TRUE))
  })
})

test_that("unknown method names error clearly", {
  ts <- TetradSearch$new()
  expect_error(
    ts$set_score("definitely_not_a_score"),
    "Unknown score type using tetrad engine"
  )
  expect_error(
    ts$set_test("definitely_not_a_test"),
    "Unknown test type using tetrad engine"
  )
  expect_error(
    ts$set_alg("definitely_not_an_alg"),
    "Unknown method type using tetrad engine"
  )
})

test_that("set_alg() succeeds for score-only algorithms when a score is set and fails if not", {
  score_only <- c(
    "fges",
    "fges_mb",
    "boss",
    "restricted_boss",
    "sp",
    "fask",
    "direct_lingam"
  )

  purrr::walk(score_only, \(alg) {
    ts <- TetradSearch$new()
    ts$set_score("sem_bic")
    expect_no_condition(ts$set_alg(alg))
  })
  purrr::walk(score_only, \(alg) {
    ts <- TetradSearch$new()
    expect_error(ts$set_alg(alg))
  })
})

test_that("set_alg() succeeds for test-only algorithms when a test is set and fails if not", {
  test_only <- c(
    "pc",
    "cpc",
    "pc_max",
    "fci",
    "rfci",
    "cfci",
    "ccd"
  )

  purrr::walk(test_only, \(alg) {
    ts <- TetradSearch$new()
    ts$set_test("fisher_z")
    expect_no_condition(ts$set_alg(alg))
  })
  purrr::walk(test_only, \(alg) {
    ts <- TetradSearch$new()
    expect_error(ts$set_alg(alg))
  })
})

test_that("set_alg() succeeds for algorithms that require both score and test and fails if both are not provided", {
  both_required <- c(
    "gfci",
    "grasp",
    "grasp_fci",
    "sp_fci",
    "boss_fci",
    "fcit",
    "cstar"
  )

  purrr::walk(both_required, \(alg) {
    ts <- TetradSearch$new()
    ts$set_score("sem_bic")
    ts$set_test("fisher_z")
    expect_no_condition(ts$set_alg(alg))
  })
  purrr::walk(both_required, \(alg) {
    ts <- TetradSearch$new()
    ts$set_test("fisher_z")
    expect_error(ts$set_alg(alg))
  })
  purrr::walk(both_required, \(alg) {
    ts <- TetradSearch$new()
    ts$set_score("sem_bic")
    expect_error(ts$set_alg(alg))
  })
})

test_that("set_alg() succeeds for algorithms with no explicit precheck", {
  # these don't check prerequisites in set_alg(); just ensure they construct
  loose <- c(
    "dagma",
    "ica_lingam",
    "ica_lingd"
  )

  purrr::walk(loose, \(alg) {
    ts <- TetradSearch$new()
    expect_no_condition(ts$set_alg(alg))
  })
})

test_that("set_alg() warns when background knowledge is set for algorithms that do not use it", {
  no_background_algorithms <- c(
    "restricted_boss",
    "cstar",
    "ica_lingam",
    "ica_lingd",
    "ccd",
    "direct_lingam",
    "dagma"
  )
  data(num_data)

  purrr::walk(no_background_algorithms, \(alg) {
    ts <- TetradSearch$new()
    kn_list <- make_knowledge_test_object(num_data)
    ts$set_knowledge(kn_list$combi_kn)
    ts$set_score("sem_bic")
    ts$set_test("fisher_z")
    ts$set_data(num_data)
    expect_warning(ts$set_alg(alg))
  })
})


test_that("get_parameters_for_function() returns names for an algorithm", {
  # alg branch
  ts <- TetradSearch$new()
  pars <- ts$get_parameters_for_function("fges", alg = TRUE)
  expect_type(pars, "character")
  expect_true(length(pars) >= 1)
})

test_that("get_parameters_for_function() returns names for a score", {
  # score branch: matches ^(set_|use_)sem_bic(_score)?$
  ts <- TetradSearch$new()
  pars <- ts$get_parameters_for_function("sem_bic", score = TRUE)
  expect_type(pars, "character")
  expect_true(length(pars) >= 1)
})

test_that("get_parameters_for_function() returns names for a test", {
  # test branch: matches ^(set_|use_)fisher_z(_test)?$
  ts <- TetradSearch$new()
  pars <- ts$get_parameters_for_function("fisher_z", test = TRUE)
  expect_type(pars, "character")
  expect_true(length(pars) >= 1)
})

test_that("get_parameters_for_function() errors when there is no match", {
  ts <- TetradSearch$new()
  expect_error(
    ts$get_parameters_for_function("this_pattern_matches_nothing", alg = TRUE),
    "There is 0 matches to the function pattern"
  )
})

test_that("get_parameters_for_function() enforces exclusivity of flags", {
  ts <- TetradSearch$new()
  expect_error(
    ts$get_parameters_for_function("fges", score = TRUE, alg = TRUE),
    "\\(Exclusively\\) one of them should be TRUE\\."
  )
})

test_that("get_parameters_for_function() errors if no flag is TRUE", {
  ts <- TetradSearch$new()
  expect_error(
    ts$get_parameters_for_function("fges"),
    "Score is: FALSE, test is: FALSE, and alg is: FALSE. (Exclusively) one of them should be TRUE",
    fixed = TRUE
  )
})

# ──────────────────────────────────────────────────────────────────────────────
# Search
# ──────────────────────────────────────────────────────────────────────────────

test_that("run_search() errors when pieces are missing", {
  # no data
  ts <- TetradSearch$new()
  ts$set_score("sem_bic")
  ts$set_alg("fges")
  expect_error(ts$run_search(), "No data is set", fixed = TRUE)

  # data but no algorithm
  data(num_data)
  ts2 <- TetradSearch$new()
  ts2$set_data(num_data)
  expect_error(ts2$run_search(), "No algorithm is set", fixed = TRUE)
})

test_that("FGES pipeline runs; toggles populate outputs; accessors work", {
  data(num_data)

  ts <- TetradSearch$new()
  ts$set_data(num_data)
  ts$set_score("sem_bic")
  ts$set_alg("fges")

  # keep bootstrap light so CI stays snappy
  ts$set_bootstrapping(
    number_resampling = 5L,
    percent_resample_size = 50,
    add_original = TRUE,
    with_replacement = TRUE,
    resampling_ensemble = 1L,
    seed = 1L
  )

  res <- ts$run_search(
    bootstrap = TRUE
  )

  # main return type
  expect_s3_class(res, "Disco")

  # java result object exists
  expect_jobj(ts$get_java())

  # dot / amat are non-empty strings
  dot <- ts$get_dot()
  amat <- ts$get_amat()
  expect_type(dot, "character")
  expect_type(amat, "character")
  expect_true(nzchar(dot))
  expect_true(nzchar(amat))
})

test_that("run_search(num_data) works instead of using set_data(num_data)", {
  data(num_data)

  ts <- TetradSearch$new()
  ts$set_score("sem_bic")
  ts$set_alg("fges")

  res <- ts$run_search(num_data)

  # main return type
  expect_s3_class(res, "Disco")

  # java result object exists
  expect_jobj(ts$get_java())

  # dot / amat are non-empty strings
  dot <- ts$get_dot()
  amat <- ts$get_amat()
  expect_type(dot, "character")
  expect_type(amat, "character")
  expect_true(nzchar(dot))
  expect_true(nzchar(amat))
})

test_that("getters work after a run", {
  data(num_data)

  ts <- TetradSearch$new()
  ts$set_data(num_data)
  ts$set_score("sem_bic")
  ts$set_alg("fges")

  res <- ts$run_search()
  expect_s3_class(res, "Disco")

  # data + java objects
  expect_jobj(ts$get_data())
  expect_jobj(ts$get_java())

  # get_string: default and explicit
  s1 <- ts$get_string()
  s2 <- ts$get_string(ts$get_java())
  expect_type(s1, "character")
  expect_true(nzchar(s1))
  expect_type(s2, "character")
  expect_true(nzchar(s2))

  # dot / amat
  dot <- ts$get_dot()
  amat <- ts$get_amat()
  expect_type(dot, "character")
  expect_true(nzchar(dot))
  expect_type(amat, "character")
  expect_true(nzchar(amat))
})

test_that("get_dot() and get_amat() cover explicit java_obj + cast_obj branch", {
  data(num_data)

  ts <- TetradSearch$new()
  ts$set_data(num_data)
  ts$set_score("sem_bic")
  ts$set_alg("fges")
  ts$run_search()

  g <- ts$get_java() # a Graph jobjRef
  expect_jobj(g)

  # explicit java_obj → exercises cast_obj(java_obj) for Graph
  dot_explicit <- ts$get_dot(g)
  amat_explicit <- ts$get_amat(g)

  expect_type(dot_explicit, "character")
  expect_type(amat_explicit, "character")
  expect_true(nzchar(dot_explicit))
  expect_true(nzchar(amat_explicit))
})