tests/testthat/test-summons.R

In asshah4/forks: Formula Spells

test_that("custom formuals can be initialized", {

  # Scripts
  f <- mpg + wt ~ X(hp) + X(cyl) + gear + drat + log(qsec)
  t <- distill_rune(f)
  x <- cast_spell(t, pattern = "direct")
  fl <- summon_formulas(x, order = 2:4)
  expect_length(fl, 7)
  expect_length(fmls(x, order = 2), 4)
  expect_length(fmls(x, order = 3), 2)
  expect_length(fmls(x, order = 4), 1)

  # Terms
  f <- mpg + wt ~ X(hp) + X(cyl) + gear + drat + log(qsec)
  t <- distill_rune(f)
  x <- summon_formulas(t)
  expect_s3_class(x, "fmls")

  y <- distill_rune("Y", side = "left")
  x <- distill_rune("X", side = "right")
  t <- c(x, y)
  f <- fmls(t, order = 1)

  # Formula
  f <- mpg ~ wt + hp + S(cyl)
  x <- summon_formulas(f)
  expect_s3_class(x, "fmls")
  expect_true(is_formulas(x))

  # Labeled components
  x <- cast_spell(mpg ~ wt + S(vs) + S(am))
  f <- summon_formulas(x,
                       label = list(vs ~ "Vroom Sounds",
                                    am ~ "Automatic Transmission"))

  # Character look alikes
  f <- "mpg ~ wt + hp"
  x <- summon_formulas(f)
  expect_match(as.character(field(x, "outcome")[[1]]), "mpg")

  # Errors
  expect_error(summon_formulas(1))
  expect_error(summon_formulas("test"))
})

test_that("output is appropriate", {

  # Empty
  expect_output(print(fmls()), "[0]")

  # Simple output
  f <- cast_spell(mpg ~ wt + hp + S(cyl), pattern = "sequential")
  x <- summon_formulas(f)
  expect_type(format(x), "character")

  # Tibble
  if (isTRUE(requireNamespace("tibble", quietly = TRUE))) {
    tibble::tibble(x) |>
      print() |>
      expect_output("<fmls>")
  }

})

test_that("casting and coercion for formulas works", {

  # Character
  f <- "mpg ~ wt + hp"
  x <- c(fmls(f), f)
  expect_length(x, 2)
  expect_type(x, "character")
  x <- vec_c(f, fmls(f))
  expect_length(x, 2)
  expect_type(x, "character")

})

test_that("appropriate orders of formulas occur", {

  # Simple order check
  x <- cast_spell(mpg ~ wt + hp, pattern = "direct")
  f <- fmls(x, order = 1:4)
  expect_length(x, 1)

  # Complex breakdown to order 1
  x <- cast_spell(mpg + wt ~ X(hp) + am, pattern = "sequential")
  f <- fmls(x, order = 1:2)
  expect_length(f, 6)
  expect_length(f[field(f, "n") == 2], 4)

  # Long lists of sequential with default order of 2:4
  f <- mpg + wt ~ X(hp) + X(cyl) + gear + drat + qsec
  labels <- list(mpg ~ "Mileage", hp ~  "Horsepower")
  tiers <- list(c(drat, qsec) ~ "speed", wt ~ "hardware")
  t <- distill_rune(f, label = labels, tier = tiers)
  x <- cast_spell(t, pattern = "sequential")
  fl <- fmls(x)
  expect_length(fl, 19)

  # Mediation break down works
  t <- distill_rune(mpg + wt ~ X(hp) + M(cyl) + qsec)
  x <- cast_spell(t)
  f <- fmls(x, order = 1:4)
  expect_length(f, 8)

})

test_that("appropriate family tracking occurs in strata", {
  f <- mpg ~ X(wt) + hp + qsec + S(cyl)
  label <- list(mpg ~ "Mileage", hp ~ "Horsepower")
  tier <- list(qsec ~ "speed", wt ~ "hardware")
  t <- distill_rune(f, label = label, tier = tier)
  x <- cast_spell(t, pattern = "sequential")
  fl <- summon_formulas(x)
  expect_equal(field(fl, "order")[1], 2)
  expect_equal(field(fl, "order")[2], 2)
  expect_equal(field(fl, "formulas")[1], "mpg ~ wt")
  expect_equal(field(fl, "ancestor")[1], field(fl, "ancestor")[2])
  expect_equal(as.character(field(fl, "strata")[[1]]), "cyl")
})


test_that("multiple strata expand appropriately", {

  x <- cast_spell(mpg ~ X(wt) + C(hp) + S(am) + S(vs), pattern = "direct")
  f <- fmls(x, order = 2)
  expect_length(f, 2)
  f <- fmls(x, order = 3)
  expect_length(f, 1)
  expect_s3_class(f, "fmls")

  # Should have three formulas total when sequential
  f <- mpg ~ X(wt) + hp + qsec + S(cyl)
  labels <- list(mpg ~ "Mileage", hp ~  "Horsepower")
  tiers <- list(c(drat, qsec) ~ "speed", wt ~ "hardware")
  t <- distill_rune(f, label = labels, tier = tiers)
  x <- cast_spell(t, pattern = "sequential")
  fl <- fmls(x)
  expect_length(fl, 3)
  expect_equal(field(fl, "number"), 1:3)
  expect_equal(field(fl, "n"), 3:5)
  expect_length(fmls(x, order = 1:4), 5)

})

test_that("pattern expansion works", {

  # Sequential
  f <- mpg ~ X(wt) + hp + qsec
  labels <- list(mpg ~ "Mileage", hp ~  "Horsepower")
  t <- distill_rune(f, label = labels)
  x <- cast_spell(t, pattern = "sequential")
  fl <- fmls(x)
  expect_length(fl, 3)
  expect_equal(field(fl, "number"), 1:3)

  # Parallel
  f <- mpg ~ X(wt) + hp + qsec
  labels <- list(mpg ~ "Mileage", hp ~  "Horsepower")
  t <- distill_rune(f, label = labels)
  x <- cast_spell(t, pattern = "parallel")
  fl <- summon_formulas(x)
  expect_length(fl, 2)
  expect_equal(field(fl, "number"), 1:2)

})

test_that("survival terms work for formulas", {

  # Testing more complex survival models
  x <- cast_spell(
    Surv(death_timeto, death_any_yn) + Surv(death_timeto, death_cv_yn) ~
      X(hf_stress_rest_delta_zn) + hf_rest_ln_zn + age_bl + blackrace +  hx_hypertension_bl + hx_diabetes_bl + hx_hbchol_bl + cath_gensini_bl + ejection_fraction + S(female_bl),
    pattern = "sequential"
  )
  f <- fmls(x, order = 2)
  expect_length(f, 18)

})

test_that("interaction works", {

  x <- distill_rune(mpg ~ X(hp) + gear + In(am))
  s <- cast_spell(x, pattern = "sequential")
  f <- fmls(s, order = 2)
  expect_length(f, 3)

})