tests/testthat/test-tidiers.R

In openpharma/mmrm: Mixed Models for Repeated Measures

# glance ----

test_that("glance returns expected values in summary in tibble form", {
  object <- get_mmrm()
  result <- object |> glance()
  expected <- summary(object)$aic_list
  expect_tibble(result)
  expect_equal(as.list(result), expected, tolerance = 1e-4)
})

# tidy ----

test_that("tidy returns expected values in summary in tibble form", {
  object <- get_mmrm()
  result <- object |> tidy()
  expected <- summary(object)$coef
  expect_tibble(result)

  estimate_result <- as.numeric(result[[2]])
  estimate_expected <- as.numeric(expected[, 1])
  expect_equal(estimate_result, estimate_expected)
})

test_that("tidy conf.int", {
  object <- get_mmrm()
  result <- tidy(object, conf.int = TRUE)
  result <- result[, c(1, 7, 8)]
  expected <- h_tbl_confint_terms(object)
  expected <- expected[order(expected$term), ]
  expect_true(inherits(result, "tbl"))
  expect_equal(result, expected)
})

test_that("tidy conf.int level", {
  object <- get_mmrm()
  result <- tidy(object, conf.int = TRUE, conf.level = 0.9)
  result <- result[, c(1, 7, 8)]
  expected <- h_tbl_confint_terms(object, level = 0.9)
  expected <- expected[order(expected$term), ]
  expect_tibble(result)
  expect_equal(result, expected)
})

# augment ----

test_that("augment returns tibble form when called with default arguments", {
  object <- get_mmrm()
  result <- augment(object)
  expect_tibble(result)
})

test_that("augment returns prediction", {
  object <- get_mmrm()
  result <- augment(object, newdata = object$data)
  expected <- as.numeric(predict(object, newdata = object$data))
  expect_equal(result$.fitted, expected)
})

test_that("augment returns prediction with confidence interval", {
  object <- get_mmrm()
  result <- augment(object, newdata = object$data, interval = "confidence")
  result_ci <- result[, c(".fitted", ".se.fit", ".lower", ".upper")]
  expected <- tibble::as_tibble(predict(
    object,
    newdata = object$data,
    se.fit = TRUE,
    interval = "confidence"
  ))
  names(expected) <- c(".fitted", ".se.fit", ".lower", ".upper")
  expect_equal(result_ci, expected)
})

test_that("augment returns prediction with confidence interval with level", {
  object <- get_mmrm()
  result <- augment(object, newdata = object$data, interval = "confidence", level = 0.9)
  result_ci <- result[, c(".fitted", ".se.fit", ".lower", ".upper")]
  expected <- tibble::as_tibble(predict(
    object,
    newdata = object$data,
    se.fit = TRUE,
    interval = "confidence",
    level = 0.9
  ))
  names(expected) <- c(".fitted", ".se.fit", ".lower", ".upper")
  expect_equal(result_ci, expected)
})

test_that("augment returns prediction with prediction interval", {
  object <- get_mmrm()
  set.seed(132)
  result <- augment(object, newdata = object$data, interval = "prediction", nsim = 10L)
  result_pi <- result[, c(".fitted", ".se.fit", ".lower", ".upper")]
  set.seed(132)
  expected <- tibble::as_tibble(predict(
    object,
    newdata = object$data,
    se.fit = TRUE,
    interval = "prediction",
    nsim = 10L
  ))
  names(expected) <- c(".fitted", ".se.fit", ".lower", ".upper")
  expect_equal(result_pi, expected)
})

test_that("augment returns prediction with prediction interval with level", {
  object <- get_mmrm()
  set.seed(132)
  result <- augment(object, newdata = object$data, interval = "prediction", level = 0.9, nsim = 10L)
  result_pi <- result[, c(".fitted", ".se.fit", ".lower", ".upper")]
  set.seed(132)
  expected <- tibble::as_tibble(predict(
    object,
    newdata = object$data,
    se.fit = TRUE,
    interval = "prediction",
    nsim = 10L,
    level = 0.9
  ))
  names(expected) <- c(".fitted", ".se.fit", ".lower", ".upper")
  expect_equal(result_pi, expected)
})

test_that("augment returns residuals response", {
  object <- get_mmrm()
  result <- augment(object, type.residuals = "response")
  result_resid <- result$.resid
  expected <- residuals(object, type = "response")
  expect_equal(result_resid, expected)
})

test_that("augment returns residuals pearson", {
  object <- get_mmrm()
  result <- augment(object, type.residuals = "pearson")
  result_resid <- result$.resid
  expected <- residuals(object, type = "pearson")
  expect_equal(result_resid, expected)
})

test_that("augment returns residuals normalized", {
  object <- get_mmrm()
  result <- augment(object, type.residuals = "normalized")
  result_resid <- result$.resid
  expected <- residuals(object, type = "normalized")
  expect_equal(result_resid, expected)
})

# h_tbl_confint_terms ----

test_that("h_tbl_confint_terms works as expected", {
  object <- get_mmrm()
  result <- expect_silent(h_tbl_confint_terms(object))
  expect_tibble(result, nrows = 11, ncols = 3)
  expect_names(names(result), identical.to = c("term", "conf.low", "conf.high"))
})

test_that("h_tbl_confint_terms works for model with only intercept", {
  object <- mmrm(FEV1 ~ 1 + us(AVISIT | USUBJID), data = fev_data)
  result <- expect_silent(h_tbl_confint_terms(object))
  expect_tibble(result, nrows = 1, ncols = 3)
  expect_names(names(result), identical.to = c("term", "conf.low", "conf.high"))
  expect_identical(result$term[1L], "(Intercept)")
})

# h_newdata_add_pred ----

test_that("h_newdata_add_pred works as expected when se_fit and interval requested", {
  object <- get_mmrm()
  result <- expect_silent(h_newdata_add_pred(
    x = object,
    newdata = object$data,
    se_fit = TRUE,
    interval = "confidence"
  ))
  expect_tibble(result, nrows = nrow(object$data))
  expect_names(names(result), must.include = c(".fitted", ".lower", ".upper", ".se.fit"))
  expect_numeric(result$.fitted, any.missing = FALSE)
  expect_numeric(result$.lower, any.missing = FALSE)
  expect_numeric(result$.upper, any.missing = FALSE)
  expect_numeric(result$.se.fit, any.missing = FALSE)
})

test_that("h_newdata_add_pred fails when se_fit requested with interval none", {
  object <- get_mmrm()
  expect_error(
    h_newdata_add_pred(
      x = object,
      newdata = object$data,
      se_fit = TRUE,
      interval = "none"
    ),
    "Must be FALSE"
  )
})

test_that("h_newdata_add_pred works as expected when interval requested but not se_fit", {
  object <- get_mmrm()
  result <- expect_silent(h_newdata_add_pred(
    x = object,
    newdata = object$data,
    se_fit = FALSE,
    interval = "confidence"
  ))
  expect_tibble(result, nrows = nrow(object$data))
  expect_names(
    names(result),
    must.include = c(".fitted", ".lower", ".upper"),
    disjunct.from = ".se.fit"
  )
})

test_that("h_newdata_add_pred works when only fit requested", {
  object <- get_mmrm()
  result <- expect_silent(h_newdata_add_pred(
    x = object,
    newdata = object$data,
    se_fit = FALSE,
    interval = "none"
  ))
  expect_tibble(result, nrows = nrow(object$data))
  expect_names(
    names(result),
    must.include = c(".fitted"),
    disjunct.from = c(".se.fit", ".lower", ".upper")
  )
})

# h_df_to_tibble ----

test_that("h_df_to_tibble works as expected", {
  df <- data.frame(a = 5, b = 3)
  result <- expect_silent(h_df_to_tibble(df))
  expected <- tibble::tibble(a = 5, b = 3)
  expect_identical(result, expected)
})

test_that("h_df_to_tibble adds a .rownames column as expected", {
  df <- data.frame(a = 5, b = 3, row.names = "first")
  result <- expect_silent(h_df_to_tibble(df))
  expected <- tibble::tibble(.rownames = "first", a = 5, b = 3)
  expect_identical(result, expected)
})

test_that("h_df_to_tibble catches errors with a useful message", {
  not_df <- get_mmrm()
  expect_error(h_df_to_tibble(not_df), "Could not coerce data to `tibble`")
})