tests/testthat/test-spells.R

In asshah4/archetypes: Formula Spells

test_that("a formula can be upgraded into a spell object", {
  f <- cast_spell(
    mpg + wt ~ hp + cyl + gear + drat + qsec,
    role = list(hp ~ "exposure", cyl ~ "mediator")
  )
  expect_length(f, 1)
  expect_length(rhs(f), 5)
  expect_length(lhs(f), 2)
})

test_that("basic formula vector can be made and displayed", {

  # Construction
  f <- mpg + wt ~ X(hp) + X(cyl) + gear + drat + log(qsec)
  t <- distill_rune(f)
  f1 <- cast_spell(t, label = list(mpg ~ "Mileage", cyl ~ "Cylinders"))
  expect_length(rhs(f1), 5)
  expect_length(lhs(f1), 2)
  expect_true(is_spell(f1))

  expect_silent(validate_class(f1, "spell"))
  expect_silent(validate_class(t, "rune"))
  expect_s3_class(f1, "spell")
  expect_equal(
    f1,
    cast_spell(x = distill_rune(
      f,
      label = list(mpg ~ "Mileage", cyl ~ "Cylinders")
    ))
  )
  expect_s3_class(cast_spell(f), "spell") # Until formal implementation is made

  # Vectorization
  t1 <- distill_rune(mpg ~ wt)
  t2 <- distill_rune(mpg ~ hp)
  f1 <- cast_spell(t1)
  f2 <- cast_spell(t2)
  f <- c(f1, f2)
  expect_length(f, 2)

  # Printing
  expect_output(print(f1), "[1]")
  expect_output(print(new_spell()), "[0]")
  if (isTRUE(requireNamespace("tibble", quietly = TRUE))) {
    tibble::tibble(f1) |>
      print() |>
      expect_output("<sx>")
  }
})

test_that("spell() inputs are acceptable", {

  # tiers
  t1 <- distill_rune(mpg ~ wt + hp + drat + qsec)
  t2 <- distill_rune("gear", side = "right", tier = "hardware")
  t3 <- distill_rune("cyl", side = "right", tier = "hardware")
  t4 <- c(t1, t2, t3)
  expect_length(t4, 7)
  f1 <- cast_spell(t4)
  tiers <- list(gear + cyl ~ "hardware")
  f2 <- cast_spell(t4, tier = tiers)
  expect_equal(f1, f2)

  t <- distill_rune(mpg + wt ~ X(hp) + X(cyl) + gear + drat + log(qsec))
  expect_length(lhs(cast_spell(t)), 2)

  # Using a formula directly
  expect_message(cast_spell(formula()))
  x <- mpg + qsec ~ X(wt) + M(hp)
  f <- cast_spell(x)
  expect_error(cast_spell("x"))

  # Modifiers such as roles, labels, and tiers are incorporated
  f <- cast_spell(x, label = list(hp ~ "Horsepower"))
  expect_length(labels(f), 1) # Currently erroring
})

test_that("spells can be made with appropriate warnings for interactions", {

  f <- mpg ~ X(hp) + gear + In(am)
  x <- distill_rune(f)
  s1 <- cast_spell(x)
  s2 <- cast_spell(
    mpg ~ hp + gear + am,
    role = list(hp ~ "exposure", am ~ "interaction")
  )

  expect_equal(s1, s2)

})

test_that("complex survival formulas can be made", {

  # Survival
  x <- Surv(stop, status) + Surv(stop, censor) ~ X(primary) + secondary + tertiary
  t <- distill_rune(x)
  f1 <- cast_spell(x)
  f2 <- cast_spell(t)
  expect_equal(f1, f2)

  # Mediation
  x <- Surv(stop, status) + Surv(stop, censor) ~ X(primary) + M(secondary) + tertiary
  t <- distill_rune(x)
  f1 <- cast_spell(x)
  f2 <- cast_spell(t)
  expect_equal(f1, f2)

  # Multiple exposures and outcomes
  x <- Surv(stop, status) + Surv(stop, censor) ~ X(primary) + X(secondary) + tertiary
  f1 <- cast_spell(Surv(stop, status) + Surv(stop, censor) ~ X(primary) + X(secondary) + tertiary)
  f2 <- cast_spell(x)
  expect_equal(f1, f2)
})

test_that("vctrs casting and coercion work appropriately", {
  f <- mpg + wt ~ X(hp) + X(cyl) + gear + drat + qsec
  t <- distill_rune(f)
  f1 <- cast_spell(x = t)

  # spell()
  f2 <- cast_spell(x = f)
  expect_equal(f1, f2)
  expect_output(print(vec_ptype2(f1, t)), "rune")
  expect_output(print(vec_ptype2(f1, f2)), "spell")

  # character()
  expect_type(as.character(f1), "character")

  # Between terms and formulas
  x <- mpg + qsec ~ X(wt) + M(hp)
  f0 <- cast_spell(x)
  t1 <- distill_rune(x)
  t2 <- distill_rune(f0)
  expect_equal(t1, t2)
  f1 <- cast_spell(t1)
  expect_equal(f0, f1)

  # Into formulas
  expect_s3_class(stats::formula(f0), "formula")
})

test_that("formula vectors can be modified in place", {

  # Updates to the right
  x <- mpg + wt ~ hp + cyl + gear
  t <- distill_rune(x)
  f1 <- cast_spell(t)
  object <- f1
  parameters <- ~ drat - gear
  expect_length(rhs(parameters, tidy = FALSE), 1)
  f2 <- update(object, parameters)
  expect_length(f2, 1)
  expect_no_match(format(f2), "gear")

  # Updates to the left
  object <- f2
  parameters <- gear - wt ~ wt
  expect_length(lhs(parameters, tidy = FALSE), 1)
  f3 <- update(object, parameters)
  expect_length(f3, 1)
  expect_length(distill_rune(f3), 6)
  expect_match(format(f3), "mpg\ \\+\ gear")

  # Complex addition and subtraction via updates
  object <- f3
  parameters <- -mpg ~ -cyl - drat - wt
  f4 <- update(object, parameters)
  expect_match(format(f4), "gear ~ hp")

  # Addition
  x <- mpg + wt ~ X(hp) + X(cyl) + gear
  t <- distill_rune(x)
  f1 <- cast_spell(t)
  f2 <- cast_spell(t[1:4])
  f3 <- add(f2, t[5])
  expect_equal(f1, f3)
  expect_s3_class(update(f2, ~gear), "spell")
})