Closes #10 add ard_vif() (#61)

**What changes are proposed in this pull request?**
added `ard_vif()` which is essentially a wrapper for `car::vif()` put
into our ard structure

Provide more detail here as needed.

**Reference GitHub issue associated with pull request.** _e.g., 'closes
#<issue number>'_



--------------------------------------------------------------------------------

Pre-review Checklist (if item does not apply, mark is as complete)
- [x] **All** GitHub Action workflows pass with a ✅
- [x] PR branch has pulled the most recent updates from master branch:
`usethis::pr_merge_main()`
- [x] If a bug was fixed, a unit test was added.
- [x] Code coverage is suitable for any new functions/features
(generally, 100% coverage for new code): `devtools::test_coverage()`
- [x] Request a reviewer

Reviewer Checklist (if item does not apply, mark is as complete)

- [x] If a bug was fixed, a unit test was added.
- [x] Run `pkgdown::build_site()`. Check the R console for errors, and
review the rendered website.
- [x] Code coverage is suitable for any new functions/features:
`devtools::test_coverage()`

When the branch is ready to be merged:
- [ ] Update `NEWS.md` with the changes from this pull request under the
heading "`# cards (development version)`". If there is an issue
associated with the pull request, reference it in parentheses at the end
update (see `NEWS.md` for examples).
- [x] **All** GitHub Action workflows pass with a ✅
- [ ] Approve Pull Request
- [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge".

---------

Signed-off-by: Daniel Sjoberg <danield.sjoberg@gmail.com>
Signed-off-by: Zelos Zhu <zelos.zhu@atorusresearch.com>
Co-authored-by: Daniel Sjoberg <danield.sjoberg@gmail.com>

Author: zdz2101

NAMESPACE

@@ -22,6 +22,7 @@ export(ard_regression)
 export(ard_regression_basic)
 export(ard_smd)
 export(ard_ttest)
+export(ard_vif)
 export(ard_wilcoxtest)
 export(contains)
 export(ends_with)

R/ard_vif.R

@@ -0,0 +1,99 @@
+#' Regression VIF ARD
+#'
+#' @description
+#' Function takes a regression model object and returns the variance inflation factor (VIF)
+#' using [`car::vif()`] and converts it to a ARD structure
+#'
+#' @param x regression model object
+#' See car::vif() for details
+#'
+#' @param ... arguments passed to `car::vif(...)`
+#'
+#' @return data frame
+#' @name ard_vif
+#' @rdname ard_vif
+#' @export
+#'
+#' @examples
+#' lm(AGE ~ ARM + SEX, data = cards::ADSL) |>
+#'   ard_vif()
+ard_vif <- function(x, ...) {
+  # check inputs ---------------------------------------------------------------
+  check_not_missing(x)
+
+  vif <- cards::eval_capture_conditions(car::vif(x, ...))
+
+  # if vif failed, set result as NULL, error will be kept through eval_capture_conditions()
+  if (is.null(vif$result)) {
+    # try to capture variable names from `terms()`
+    lst_terms <- cards::eval_capture_conditions(attr(stats::terms(x), "term.labels"))
+    # we cannot get variable names, error out
+    if (!is.null(lst_terms[["error"]])) {
+      cli::cli_abort(
+        c("There was an error running {.fun car::vif}. See below.", x = vif[["error"]])
+      )
+    }
+    vif$result <- dplyr::tibble(
+      variable = lst_terms[["result"]],
+      VIF = list(NULL),
+      GVIF = list(NULL),
+      aGVIF = list(NULL),
+      df = list(NULL)
+    )
+  }
+  # if VIF is returned
+  else if (!is.matrix(vif$result)) {
+    vif$result <- dplyr::tibble(variable = names(vif$result), VIF = vif$result)
+  }
+  # if Generalized VIF is returned
+  else if (is.matrix(vif$result)) {
+    vif$result <-
+      vif$result |>
+      as.data.frame() %>%
+      dplyr::mutate(., variable = rownames(.), .before = 1L) |>
+      dplyr::rename(
+        aGVIF = "GVIF^(1/(2*Df))",
+        df = "Df"
+      ) |>
+      dplyr::tibble()
+  }
+
+  # Clean-up the result to fit the ard structure through pivot
+  vif$result <-
+    vif$result |>
+    tidyr::pivot_longer(
+      cols = -c("variable"),
+      names_to = "stat_name",
+      values_to = "stat"
+    ) |>
+    dplyr::mutate(
+      context = "vif",
+      stat_label = ifelse(
+        .data$stat_name == "aGVIF",
+        "Adjusted GVIF",
+        .data$stat_name
+      ),
+      fmt_fn = map(
+        .data$stat,
+        function(.x) {
+          # styler: off
+          if (is.integer(.x)) return(0L)
+          if (is.numeric(.x)) return(1L)
+          # styler: on
+          NULL
+        }
+      )
+    )
+
+  # Bind the results and possible warning/errors together
+  vif_return <- dplyr::tibble(
+    vif$result,
+    warning = vif["warning"],
+    error = vif["error"]
+  )
+
+  # Clean up return object
+  vif_return |>
+    cards::tidy_ard_column_order() %>%
+    {structure(., class = c("card", class(.)))}  # styler: off
+}

_pkgdown.yml

@@ -42,6 +42,7 @@ reference:
       - ard_regression
       - ard_regression_basic
       - ard_smd
+      - ard_vif
 
   - title: "Helpers"
   - contents:

inst/WORDLIST

@@ -9,6 +9,7 @@ Lifecycle
 McNemar's
 Newcombe
 Su
+VIF
 XG
 Xin
 agresti
@@ -18,6 +19,7 @@ funder
 jeffreys
 pearson
 strat
+vif
 wald
 waldcc
 wilson

man/ard_vif.Rd

@@ -0,0 +1,47 @@
+# ard_vif() works
+
+    Code
+      as.data.frame(ard_vif(lm(AGE ~ ARM + SEX, data = cards::ADSL)))
+    Output
+        variable context stat_name    stat_label     stat fmt_fn warning error
+      1      ARM     vif      GVIF          GVIF 1.015675      1    NULL  NULL
+      2      ARM     vif        df            df 2.000000      1    NULL  NULL
+      3      ARM     vif     aGVIF Adjusted GVIF 1.003896      1    NULL  NULL
+      4      SEX     vif      GVIF          GVIF 1.015675      1    NULL  NULL
+      5      SEX     vif        df            df 1.000000      1    NULL  NULL
+      6      SEX     vif     aGVIF Adjusted GVIF 1.007807      1    NULL  NULL
+
+---
+
+    Code
+      as.data.frame(ard_vif(lm(AGE ~ BMIBL + EDUCLVL, data = cards::ADSL)))
+    Output
+        variable context stat_name stat_label     stat fmt_fn warning error
+      1    BMIBL     vif       VIF        VIF 1.010522      1    NULL  NULL
+      2  EDUCLVL     vif       VIF        VIF 1.010522      1    NULL  NULL
+
+# ard_vif() appropriate errors are given for model with only 1 term
+
+    Code
+      as.data.frame(ard_vif(lm(AGE ~ ARM, data = cards::ADSL)))
+    Output
+        variable context stat_name    stat_label stat fmt_fn warning
+      1      ARM     vif       VIF           VIF NULL   NULL    NULL
+      2      ARM     vif      GVIF          GVIF NULL   NULL    NULL
+      3      ARM     vif     aGVIF Adjusted GVIF NULL   NULL    NULL
+      4      ARM     vif        df            df NULL   NULL    NULL
+                                    error
+      1 model contains fewer than 2 terms
+      2 model contains fewer than 2 terms
+      3 model contains fewer than 2 terms
+      4 model contains fewer than 2 terms
+
+# ard_vif() issues friendly messaging for incorrect object passed in/can't get terms of model
+
+    Code
+      ard_vif(cards::ADSL)
+    Condition
+      Error in `ard_vif()`:
+      ! There was an error running `car::vif()`. See below.
+      x no applicable method for 'vcov' applied to an object of class "c('tbl_df', 'tbl', 'data.frame')"
+

tests/testthat/_snaps/ard_vif.md

@@ -0,0 +1,37 @@
+test_that("ard_vif() works", {
+  expect_snapshot(
+    lm(AGE ~ ARM + SEX, data = cards::ADSL) |>
+      ard_vif() |>
+      as.data.frame()
+  )
+
+  expect_snapshot(
+    lm(AGE ~ BMIBL + EDUCLVL, data = cards::ADSL) |>
+      ard_vif() |>
+      as.data.frame()
+  )
+})
+
+test_that("ard_vif() appropriate errors are given for model with only 1 term", {
+  expect_snapshot(
+    lm(AGE ~ ARM, data = cards::ADSL) |>
+      ard_vif() |>
+      as.data.frame()
+  )
+  expect_equal(
+    lm(AGE ~ ARM, data = cards::ADSL) |>
+      ard_vif() |>
+      dplyr::select(error) |>
+      unlist() |>
+      unique(),
+    "model contains fewer than 2 terms"
+  )
+})
+
+
+test_that("ard_vif() issues friendly messaging for incorrect object passed in/can't get terms of model", {
+  expect_snapshot(
+    error = TRUE,
+    cards::ADSL |> ard_vif()
+  )
+})