modfiy closer to desired structure

insightsengineering · Feb 26, 2024 · 6ad5b37 · 6ad5b37
1 parent 50ff2ec
commit 6ad5b37
Show file tree

Hide file tree

Showing 4 changed files with 74 additions and 48 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -19,16 +19,14 @@ Imports:
     dplyr (>= 1.1.2),
     glue (>= 1.6.2),
     rlang (>= 1.1.1),
-    stringr (>= 1.4.0),
-    tibble (>= 3.2.1),
     tidyr (>= 1.3.0)
 Suggests:
     broom (>= 1.0.5),
     broom.helpers (>= 1.13.0),
     car (>= 3.0-11),
     spelling,
     testthat (>= 3.2.0),
-    withr,
+    withr
 Remotes: 
     insightsengineering/cards
 Config/Needs/website: insightsengineering/nesttemplate

diff --git a/R/ard_vif.R b/R/ard_vif.R
@@ -21,9 +21,44 @@ ard_vif <- function(x) {
   # check inputs ---------------------------------------------------------------
   check_not_missing(x, "model")
 
-  .vif_to_tibble(x) |>
+  vif_return <- .vif_to_tibble(x)
+  dplyr::tibble(
+    vif_return$result,
+    warning = vif_return["warning"],
+    error = vif_return["error"]
+  )
+}
+
+
+# put VIF results in data frame -- borrowed from gtsummary
+.vif_to_tibble <- function(x) {
+  temp <- x
+  vif <- car::vif(x) |>
+    cards::eval_capture_conditions()
+
+  # if VIF is returned
+  if (is.null(vif$result)) {
+    vif$result <- dplyr::tibble(variable = names(temp$coefficients)[-1], VIF = list(NULL))
+  }
+  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()
+  }
+
+  vif$result <-
+    vif$result |>
     tidyr::pivot_longer(
-      cols = -c("variable", "row_type"),
+      cols = -c("variable"),
       names_to = "stat_name",
       values_to = "statistic"
     ) |>
@@ -39,47 +74,6 @@ ard_vif <- function(x) {
         stat_name
       )
     )
-}
 
-
-# put VIF results in data frame -- borrowed from gtsummary
-.vif_to_tibble <- function(x) {
-  vif <- tryCatch(
-    car::vif(x),
-    error = function(e) {
-      paste(
-        "The {.code add_vif()} uses {.code car::vif()} to",
-        "calculate the VIF, and the function returned an error (see below)."
-      ) |>
-        stringr::str_wrap() |>
-        cli::cli_alert_danger()
-      stop(e)
-    }
-  )
-
-  # if VIF is returned
-  if (!is.matrix(vif)) {
-    result <-
-      vif |>
-      tibble::enframe("variable", "VIF")
-  } # if Generalized VIF is returned
-  else {
-    result <-
-      vif |>
-      as.data.frame() |>
-      tibble::rownames_to_column(var = "variable") |>
-      tibble::as_tibble() |>
-      dplyr::rename(
-        aGVIF = "GVIF^(1/(2*Df))",
-        df = "Df"
-      )
-  }
-
-  result <-
-    result |>
-    dplyr::mutate(
-      variable = broom.helpers::.clean_backticks(.data$variable),
-      row_type = "label"
-    )
-  return(result)
+  return(vif)
 }
diff --git a/tests/testthat/_snaps/ard_vif.md b/tests/testthat/_snaps/ard_vif.md
@@ -0,0 +1,26 @@
+# ard_vif() works
+
+    Code
+      ard_vif(lm(AGE ~ ARM + SEX, data = cards::ADSL))
+    Output
+      # A tibble: 6 x 7
+        variable context stat_name stat_label    statistic warning      error       
+        <chr>    <chr>   <chr>     <chr>             <dbl> <named list> <named list>
+      1 ARM      vif     GVIF      GVIF               1.02 <NULL>       <NULL>      
+      2 ARM      vif     df        df                 2    <NULL>       <NULL>      
+      3 ARM      vif     aGVIF     Adjusted GVIF      1.00 <NULL>       <NULL>      
+      4 SEX      vif     GVIF      GVIF               1.02 <NULL>       <NULL>      
+      5 SEX      vif     df        df                 1    <NULL>       <NULL>      
+      6 SEX      vif     aGVIF     Adjusted GVIF      1.01 <NULL>       <NULL>      
+
+# ard_vif() appropriate errors are given for model with only 1 term
+
+    Code
+      ard_vif(lm(AGE ~ ARM, data = cards::ADSL))
+    Output
+      # A tibble: 2 x 7
+        variable                context stat_name stat_label statistic warning   error
+        <chr>                   <chr>   <chr>     <chr>      <list>    <named l> <nam>
+      1 ARMXanomeline High Dose vif     VIF       VIF        <NULL>    <NULL>    <chr>
+      2 ARMXanomeline Low Dose  vif     VIF       VIF        <NULL>    <NULL>    <chr>
+
diff --git a/tests/testthat/test-ard_vif.R b/tests/testthat/test-ard_vif.R
@@ -6,8 +6,16 @@ test_that("ard_vif() works", {
 })
 
 test_that("ard_vif() appropriate errors are given for model with only 1 term", {
-  expect_error(
+  expect_snapshot(
     lm(AGE ~ ARM, data = cards::ADSL) |>
       ard_vif()
   )
+  expect_equal(
+    lm(AGE ~ ARM, data = cards::ADSL) |>
+      ard_vif() |>
+      dplyr::select(error) |>
+      unlist() |>
+      unique(),
+    "model contains fewer than 2 terms"
+  )
 })