tests/testthat/test-model-diagnosis-predict.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

test_that("linear diagnosis and postestimation diagnostics work", {
  d <- data.frame(
    y = c(12, 15, 17, 20, 21, 25, 28, 31, 35, 38),
    age = seq(20, 65, by = 5),
    bmi = c(19, 21, 20, 23, 25, 24, 27, 28, 30, 29)
  )
  m <- regress(y, c.age, c.bmi, data = d, diagnosis = TRUE, show = FALSE)
  expect_s3_class(m, "r4vn_stat")
  expect_true("Model diagnosis" %in% names(m$sections))
  expect_true("Influence diagnostics" %in% names(m$sections))
  expect_length(predict(m, type = "standardized"), nrow(d))
  expect_length(predict(m, type = "studentized"), nrow(d))
  expect_length(predict(m, type = "leverage"), nrow(d))
  expect_length(predict(m, type = "cooksd"), nrow(d))
  expect_length(predict(m, type = "dffits"), nrow(d))
  expect_length(predict(m, type = "covratio"), nrow(d))
  expect_length(predict(m, type = "dfbetas", term = "age"), nrow(d))
})

test_that("predict writes diagnostic variables and aligns omitted rows", {
  d <- data.frame(
    y = c(12, 15, NA, 20, 21, 25, 28, 31),
    age = c(20, 25, 30, 35, 40, 45, 50, 55),
    bmi = c(19, 21, 20, 23, 25, 24, 27, 28)
  )
  usedf(d)
  regress(y, c.age, c.bmi, show = FALSE)
  predict(newvar = stdres, type = "standardized", show = FALSE)
  out <- usedf()
  expect_true("stdres" %in% names(out))
  expect_true(is.na(out$stdres[3]))
  expect_equal(sum(is.finite(out$stdres)), 7L)
})

test_that("logistic diagnosis and diagnostics work", {
  d <- data.frame(
    y = c(0,1,0,0,1,0,1,1,0,1,0,1,1,0,1,0,1,1,0,1),
    age = seq(25, 72.5, by = 2.5),
    bmi = c(20,24,21,27,23,25,29,22,31,26,28,24,30,27,32,23,29,25,31,28)
  )
  m <- logistic(y, c.age, c.bmi, data = d, event = 1, diagnosis = TRUE, show = FALSE)
  expect_true("Model diagnosis" %in% names(m$sections))
  expect_true("Calibration / goodness of fit" %in% names(m$sections))
  expect_length(predict(m, type = "probability"), nrow(d))
  expect_length(predict(m, type = "deviance"), nrow(d))
  expect_length(predict(m, type = "standardized"), nrow(d))
  expect_length(predict(m, type = "leverage"), nrow(d))
  expect_length(predict(m, type = "cooksd"), nrow(d))
})

test_that("Poisson diagnosis reports dispersion", {
  d <- data.frame(
    cases = c(0,1,1,2,2,3,4,4,5,6,7,8),
    age = seq(20, 75, by = 5),
    time = rep(c(1, 1.5, 2), 4)
  )
  m <- poisson(cases, c.age, data = d, exposure = time, diagnosis = TRUE, show = FALSE)
  expect_true("Model diagnosis" %in% names(m$sections))
  expect_true(any(grepl("dispersion", m$sections$`Model diagnosis`$Diagnostic, ignore.case = TRUE)))
})

test_that("diagnosis defaults to FALSE", {
  d <- data.frame(y = c(1.0, 2.2, 2.9, 4.1, 5.2, 5.8, 7.1, 7.7), x = 2:9)
  m <- regress(y, x, data = d, show = FALSE)
  expect_false("Model diagnosis" %in% names(m$sections))
})

if (requireNamespace("quantreg", quietly = TRUE)) {
  test_that("quantile regression diagnosis is available", {
    d <- data.frame(y = c(1,2,3,4,6,7,9,10), x = 1:8)
    m <- qregress(y, c.x, data = d, diagnosis = TRUE, show = FALSE)
    expect_true("Model diagnosis" %in% names(m$sections))
  })
}


test_that("vars i. prefix is categorical and usable by survival-model syntax", {
  d <- data.frame(sex = c(0, 1, 0, 1))
  z <- R4VN:::.r4vn_resolve_vars(vars(i.sex), d, default_type = "auto", strict = TRUE)
  expect_equal(z$variable, "sex")
  expect_equal(z$type, "categorical")
  expect_equal(z$reference_index, 1L)
})

test_that("predict reconstructs numeric source columns as fitted factors", {
  d <- data.frame(
    y = c(0,1,0,1,0,1,0,1,1,0,1,0),
    age = c(33,41,52,45,60,38,55,47,62,36,50,58),
    htn = c(0,1,0,1,1,0,1,0,1,0,0,1)
  )
  m <- logistic(y, c.age, i.htn, data = d, event = 1, show = FALSE)
  expect_true(is.factor(stats::model.frame(m$raw$model)$htn))
  pr <- predict(m$raw$model, newdata = d[1:5, , drop = FALSE], type = "response")
  expect_length(pr, 5L)
  expect_true(all(is.finite(pr)))
})

if (requireNamespace("survival", quietly = TRUE)) {
  test_that("Cox diagnosis can be requested explicitly", {
    d <- data.frame(
      time = c(5,8,10,12,15,18,20,22,25,30),
      event = c(1,0,1,1,0,1,0,1,1,0),
      age = c(40,45,50,55,60,48,52,63,58,67),
      sex = factor(rep(c("Female", "Male"), 5))
    )
    m <- cox(time, event, vars = vars(c.age, i.sex), data = d,
             diagnosis = TRUE, show = FALSE)
    expect_s3_class(m, "r4vn_surv")
    expect_true(is.list(m$model_diagnostics))
    expect_true(length(m$model_diagnostics) >= 1L)
  })
}