Fix issues with multiple possible adjustments (#762)

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: performance
 Title: Assessment of Regression Models Performance
-Version: 0.12.2.8
+Version: 0.12.2.9
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

R/check_dag.R

@@ -227,7 +227,7 @@ check_dag <- function(...,
       adjustment_not_needed = is.null(adjustment_set) && is.null(adjustment_nodes),
       incorrectly_adjusted = is.null(adjustment_set) && !is.null(adjustment_nodes),
       current_adjustments = adjustment_nodes,
-      minimal_adjustments = adjustment_set
+      minimal_adjustments = as.list(dagitty::adjustmentSets(dag, effect = x))
     )
   })
 
@@ -247,7 +247,11 @@ check_dag <- function(...,
 
 .adjust_dag <- function(dag, adjusted) {
   for (i in adjusted) {
-    dag <- gsub(paste0("\n", i, "\n"), paste0("\n", i, " [adjusted]\n"), dag)
+    # first option, we just have the variable name
+    dag <- gsub(paste0("\n", i, "\n"), paste0("\n", i, " [adjusted]\n"), dag, fixed = TRUE)
+    # second option, we have the variable name with a [pos] tag when the user
+    # provided coords
+    dag <- gsub(paste0("\n", i, " [pos="), paste0("\n", i, " [adjusted,pos="), dag, fixed = TRUE)
   }
   dag
 }
@@ -299,6 +303,13 @@ print.check_dag <- function(x, ...) {
       out <- attributes(x)$check_total
     }
 
+    # missing adjustements - minimal_adjustment can be a list of different
+    # options for minimal adjustements, so we check here if any of the minimal
+    # adjustements are currently sufficient
+    missing_adjustments <- vapply(out$minimal_adjustments, function(i) {
+      !is.null(out$current_adjustments) && all(i %in% out$current_adjustments)
+    }, logical(1))
+
     # build message with check results for effects -----------------------
 
     if (isTRUE(out$adjustment_not_needed)) {
@@ -321,16 +332,39 @@ print.check_dag <- function(x, ...) {
         datawizard::text_concatenate(out$current_adjustments, enclose = "`"),
         "."
       )
-    } else if (length(out$current_adjustments) != length(out$minimal_adjustment)) {
+    } else if (!any(missing_adjustments)) {
       # Scenario 3: missing adjustments
       msg <- paste0(
         insight::color_text("Incorrectly adjusted!", "red"),
         "\nTo estimate the ", i, " effect, ",
         insight::color_text("also", "italic"),
-        " adjust for ",
-        insight::color_text(datawizard::text_concatenate(out$minimal_adjustments, enclose = "`"), "yellow"),
-        "."
+        " adjust for "
       )
+      # we may have multiple valid adjustment sets - handle this here
+      if (length(out$minimal_adjustments) > 1) {
+        msg <- paste0(
+          msg,
+          "one of the following sets:\n",
+          insight::color_text(
+            paste(
+              "-",
+              unlist(lapply(out$minimal_adjustments, paste, collapse = ", "), use.names = FALSE),
+              collapse = "\n"
+            ),
+            "yellow"
+          ),
+          "."
+        )
+      } else {
+        msg <- paste0(
+          msg,
+          insight::color_text(datawizard::text_concatenate(
+            unlist(out$minimal_adjustments, use.names = FALSE),
+            enclose = "`"
+          ), "yellow"),
+          "."
+        )
+      }
       if (is.null(out$current_adjustments)) {
         msg <- paste0(msg, "\nCurrently, the model does not adjust for any variables.")
       } else {

tests/testthat/_snaps/check_dag.md

@@ -128,3 +128,54 @@
       All minimal sufficient adjustments to estimate the total effect were done.
       
 
+# check_dag, multiple adjustment sets
+
+    Code
+      print(dag)
+    Output
+      # Check for correct adjustment sets
+      - Outcome: exam
+      - Exposure: podcast
+      
+      Identification of direct effects
+      
+      Incorrectly adjusted!
+      To estimate the direct effect, also adjust for one of the following sets:
+      - alertness, prepared
+      - alertness, skills_course
+      - mood, prepared
+      - mood, skills_course.
+      Currently, the model does not adjust for any variables.
+      
+      Identification of total effects
+      
+      Incorrectly adjusted!
+      To estimate the total effect, also adjust for one of the following sets:
+      - alertness, prepared
+      - alertness, skills_course
+      - mood, prepared
+      - mood, skills_course.
+      Currently, the model does not adjust for any variables.
+      
+
+---
+
+    Code
+      print(dag)
+    Output
+      # Check for correct adjustment sets
+      - Outcome: exam
+      - Exposure: podcast
+      - Adjustments: alertness and prepared
+      
+      Identification of direct effects
+      
+      Model is correctly specified.
+      All minimal sufficient adjustments to estimate the direct effect were done.
+      
+      Identification of total effects
+      
+      Model is correctly specified.
+      All minimal sufficient adjustments to estimate the total effect were done.
+      
+

tests/testthat/test-check_dag.R

@@ -47,7 +47,6 @@ test_that("check_dag", {
     wt ~ disp + cyl,
     wt ~ am
   )
-  dag
   expect_snapshot(print(dag))
 })
 
@@ -65,3 +64,30 @@ test_that("check_dag, cylic error", {
     regex = "Model is cyclic"
   )
 })
+
+
+test_that("check_dag, multiple adjustment sets", {
+  dag <- check_dag(
+    podcast ~ mood + humor + skills_course,
+    alertness ~ mood,
+    mood ~ humor,
+    prepared ~ skills_course,
+    exam ~ alertness + prepared,
+    coords = ggdag::time_ordered_coords(),
+    exposure = "podcast",
+    outcome = "exam"
+  )
+  expect_snapshot(print(dag))
+  dag <- check_dag(
+    podcast ~ mood + humor + skills_course,
+    alertness ~ mood,
+    mood ~ humor,
+    prepared ~ skills_course,
+    exam ~ alertness + prepared,
+    adjusted = c("alertness", "prepared"),
+    exposure = "podcast",
+    outcome = "exam",
+    coords = ggdag::time_ordered_coords()
+  )
+  expect_snapshot(print(dag))
+})