tests/testthat/test-normalizeMvglsFormulaCall.R

In bifrost: Branch-Level Inference Framework for Recognizing Optimal Shifts in Traits

test_that("normalizeMvglsFormulaCall rewrites response-only data.frames for trait_data ~ 1", {
  dat <- data.frame(
    y1 = c(1, 2, 3),
    y2 = c(4, 5, 6),
    row.names = c("sp1", "sp2", "sp3")
  )

  normalized <- normalizeMvglsFormulaCall(
    formula = "trait_data ~ 1",
    trait_data = dat,
    args_list = list()
  )

  testthat::expect_identical(
    paste(deparse(normalized$formula), collapse = " "),
    "cbind(y1, y2) ~ 1"
  )
  testthat::expect_true(is.data.frame(normalized$args_list$data))
  testthat::expect_identical(colnames(normalized$args_list$data), c("y1", "y2"))
  testthat::expect_identical(rownames(normalized$args_list$data), rownames(dat))
})

test_that("normalizeMvglsFormulaCall validates inputs and leaves unsupported legacy forms unchanged", {
  dat <- data.frame(
    y1 = c(1, 2, 3),
    grp = factor(c("a", "b", "a")),
    row.names = c("sp1", "sp2", "sp3")
  )

  testthat::expect_error(
    normalizeMvglsFormulaCall(
      trait_data = dat,
      args_list = list()
    ),
    "must be provided"
  )
  testthat::expect_error(
    normalizeMvglsFormulaCall(
      formula = 1,
      trait_data = dat,
      args_list = list()
    ),
    "must be provided"
  )

  unchanged <- normalizeMvglsFormulaCall(
    formula = "trait_data ~ 1",
    trait_data = dat,
    args_list = list(data = dat)
  )

  testthat::expect_identical(
    paste(deparse(unchanged$formula), collapse = " "),
    "trait_data ~ 1"
  )
  testthat::expect_identical(unchanged$args_list$data, dat)
})

test_that("normalizeMvglsFormulaCall assigns synthetic names and enforces multivariate responses by default", {
  dat <- data.frame(
    a = c(1, 2, 3),
    b = c(4, 5, 6),
    row.names = c("sp1", "sp2", "sp3")
  )
  names(dat) <- c("", "")

  normalized <- normalizeMvglsFormulaCall(
    formula = "trait_data ~ 1",
    trait_data = dat,
    args_list = list(data = dat)
  )

  testthat::expect_identical(
    paste(deparse(normalized$formula), collapse = " "),
    "cbind(Y1, Y2) ~ 1"
  )
  testthat::expect_identical(colnames(normalized$args_list$data), c("Y1", "Y2"))

  testthat::expect_error(
    normalizeMvglsFormulaCall(
      formula = y1 ~ mass,
      trait_data = data.frame(y1 = c(1, 2, 3), mass = c(4, 5, 6)),
      args_list = list(data = data.frame(y1 = c(1, 2, 3), mass = c(4, 5, 6)))
    ),
    "multivariate response"
  )
})

test_that("normalizeMvglsFormulaCall can synthesize multivariate names from matrix responses", {
  resp <- matrix(c(1, 2, 3, 4, 5, 6), ncol = 2)
  dat <- data.frame(
    resp = I(resp),
    mass = c(1, 2, 3),
    row.names = c("sp1", "sp2", "sp3")
  )

  normalized <- normalizeMvglsFormulaCall(
    formula = resp ~ mass,
    trait_data = dat,
    args_list = list(data = dat)
  )

  testthat::expect_identical(
    paste(deparse(normalized$formula), collapse = " "),
    "cbind(Y1, Y2) ~ mass"
  )
  testthat::expect_identical(colnames(normalized$args_list$data), c("Y1", "Y2", "mass"))

  matrix_dat <- matrix(
    c(1, 2, 3, 4, 5, 6, 10, 11, 12),
    ncol = 3,
    dimnames = list(c("sp1", "sp2", "sp3"), c("y1", "y2", "mass"))
  )
  matrix_normalized <- normalizeMvglsFormulaCall(
    formula = cbind(y1, y2) ~ mass,
    trait_data = matrix_dat,
    args_list = list(data = matrix_dat)
  )
  testthat::expect_true(is.data.frame(matrix_normalized$args_list$data))
  testthat::expect_identical(
    paste(deparse(matrix_normalized$formula), collapse = " "),
    "cbind(y1, y2) ~ mass"
  )
  testthat::expect_identical(rownames(matrix_normalized$args_list$data), rownames(matrix_dat))
})

test_that("normalizeMvglsFormulaCall rewrites legacy indexed formulas onto named columns", {
  dat <- data.frame(
    y1 = c(1, 2, 3),
    y2 = c(4, 5, 6),
    y3 = c(7, 8, 9),
    mass = c(10, 11, 12),
    row.names = c("sp1", "sp2", "sp3")
  )

  normalized <- normalizeMvglsFormulaCall(
    formula = "trait_data[, 2:3] ~ trait_data[, 1]",
    trait_data = dat,
    args_list = list(data = dat)
  )

  testthat::expect_identical(
    paste(deparse(normalized$formula), collapse = " "),
    "cbind(y2, y3) ~ y1"
  )
  testthat::expect_identical(rownames(normalized$args_list$data), rownames(dat))

  intercept_only <- normalizeMvglsFormulaCall(
    formula = "trait_data[, 1:2] ~ 1",
    trait_data = dat,
    args_list = list(data = dat)
  )

  testthat::expect_identical(
    paste(deparse(intercept_only$formula), collapse = " "),
    "cbind(y1, y2) ~ 1"
  )
  testthat::expect_identical(colnames(intercept_only$args_list$data), c("y1", "y2"))
})

test_that("normalizeMvglsFormulaCall handles legacy edge cases without changing formulas unnecessarily", {
  dat <- data.frame(
    y1 = c(1, 2, 3),
    y2 = c(4, 5, 6),
    trait_data = c(7, 8, 9),
    row.names = c("sp1", "sp2", "sp3")
  )

  unchanged <- normalizeMvglsFormulaCall(
    formula = "cbind(y1, y2) ~ trait_data",
    trait_data = dat,
    args_list = list(data = dat)
  )

  testthat::expect_identical(
    paste(deparse(unchanged$formula), collapse = " "),
    "cbind(y1, y2) ~ trait_data"
  )
  testthat::expect_identical(unchanged$args_list$data, dat)

  unnamed_dat <- structure(
    list(c(1, 2, 3), c(4, 5, 6)),
    class = "data.frame",
    row.names = c("sp1", "sp2", "sp3")
  )

  normalized_unnamed <- normalizeMvglsFormulaCall(
    formula = "trait_data[, 2] ~ trait_data[, 1]",
    trait_data = unnamed_dat,
    args_list = list(data = unnamed_dat),
    allow_single_response = TRUE
  )

  testthat::expect_identical(
    paste(deparse(normalized_unnamed$formula), collapse = " "),
    "cbind(V2) ~ V1"
  )
  testthat::expect_identical(colnames(normalized_unnamed$args_list$data), c("V2", "V1"))

  drop_names_method <- function(x, i, j, ..., drop = FALSE) {
    out <- NextMethod("[")
    if (is.data.frame(out)) {
      names(out) <- rep("", ncol(out))
    }
    out
  }
  assign("[.bifrost_drop_names_df", drop_names_method, envir = globalenv())
  on.exit(rm("[.bifrost_drop_names_df", envir = globalenv()), add = TRUE)

  drop_names_dat <- data.frame(
    y1 = c(1, 2, 3),
    y2 = c(4, 5, 6),
    row.names = c("sp1", "sp2", "sp3")
  )
  class(drop_names_dat) <- c("bifrost_drop_names_df", class(drop_names_dat))

  normalized_drop_names <- normalizeMvglsFormulaCall(
    formula = "trait_data[, 1:2] ~ 1",
    trait_data = drop_names_dat,
    args_list = list(data = drop_names_dat)
  )

  testthat::expect_identical(
    paste(deparse(normalized_drop_names$formula), collapse = " "),
    "cbind(Y1, Y2) ~ 1"
  )
  testthat::expect_identical(colnames(normalized_drop_names$args_list$data), c("Y1", "Y2"))
})

test_that("normalizeMvglsFormulaCall can rewrite single-response data.frames when allowed", {
  dat <- data.frame(
    y1 = c(1, 2, 3),
    row.names = c("sp1", "sp2", "sp3")
  )

  normalized <- normalizeMvglsFormulaCall(
    formula = "trait_data ~ 1",
    trait_data = dat,
    args_list = list(),
    allow_single_response = TRUE
  )

  testthat::expect_identical(
    paste(deparse(normalized$formula), collapse = " "),
    "cbind(y1) ~ 1"
  )
  testthat::expect_true(is.data.frame(normalized$args_list$data))
  testthat::expect_identical(colnames(normalized$args_list$data), "y1")
  testthat::expect_identical(rownames(normalized$args_list$data), rownames(dat))

  indexed <- normalizeMvglsFormulaCall(
    formula = "trait_data[, 1] ~ 1",
    trait_data = dat,
    args_list = list(data = dat),
    allow_single_response = TRUE
  )

  testthat::expect_identical(
    paste(deparse(indexed$formula), collapse = " "),
    "cbind(y1) ~ 1"
  )
  testthat::expect_identical(colnames(indexed$args_list$data), "y1")
})

test_that("normalizeMvglsFormulaCall can synthesize names for unnamed single responses", {
  dat <- data.frame(
    y1 = c(1, 2, 3),
    mass = c(4, 5, 6),
    row.names = c("sp1", "sp2", "sp3")
  )

  normalized <- normalizeMvglsFormulaCall(
    formula = I(y1) ~ mass,
    trait_data = dat,
    args_list = list(data = dat),
    allow_single_response = TRUE
  )

  testthat::expect_identical(
    paste(deparse(normalized$formula), collapse = " "),
    "cbind(Y1) ~ mass"
  )
  testthat::expect_true(is.data.frame(normalized$args_list$data))
  testthat::expect_identical(colnames(normalized$args_list$data), c("Y1", "mass"))
})

test_that("multiple predictors are explicit and indexed blocks give migration guidance", {
  dat <- data.frame(y1 = c(2, 1, 4, 3), y2 = c(4, 6, 5, 8),
                    x1 = c(0, 1, 0, 1), x2 = c(1, 1, 2, 2))
  testthat::expect_error(
    normalizeMvglsFormulaCall("trait_data[, 1:2] ~ trait_data[, 3:4]", dat, list()),
    "trait_data[, 3] + trait_data[, 4]", fixed = TRUE
  )
  expected_design <- cbind(`(Intercept)` = 1, x1 = dat$x1, x2 = dat$x2)
  rownames(expected_design) <- rownames(dat)
  for (formula in c("cbind(y1, y2) ~ x1 + x2",
                    "trait_data[, 1:2] ~ trait_data[, 3] + trait_data[, 4]")) {
    normalized <- normalizeMvglsFormulaCall(formula, dat, list())
    frame <- stats::model.frame(normalized$formula, normalized$args_list$data)
    testthat::expect_equal(stats::model.matrix(normalized$formula, frame),
                          expected_design, ignore_attr = TRUE)
    testthat::expect_equal(unname(stats::model.response(frame)),
                          unname(as.matrix(dat[c("y1", "y2")])))
  }
})