From e9c4c06814d254885ea5cabb7117f56332efe09a Mon Sep 17 00:00:00 2001 From: Daniel Date: Thu, 8 Aug 2024 20:07:36 +0200 Subject: [PATCH 1/4] Fix issues with multiple possible adjustments --- R/check_dag.R | 46 ++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 40 insertions(+), 6 deletions(-) diff --git a/R/check_dag.R b/R/check_dag.R index 0f29863af..a4a4c0e7f 100644 --- a/R/check_dag.R +++ b/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(out$current_adjustments %in% i) + }, 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 { From 1da046240348eb39603acdf01f7d424a55f6383f Mon Sep 17 00:00:00 2001 From: Daniel Date: Thu, 8 Aug 2024 20:08:47 +0200 Subject: [PATCH 2/4] version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1354d9678..4cdb94862 100644 --- a/DESCRIPTION +++ b/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", From 0f7dbf70bad54619036e0be9ff0b062f62452a34 Mon Sep 17 00:00:00 2001 From: Daniel Date: Sat, 10 Aug 2024 00:08:27 +0200 Subject: [PATCH 3/4] fix --- R/check_dag.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/check_dag.R b/R/check_dag.R index a4a4c0e7f..b78090a6f 100644 --- a/R/check_dag.R +++ b/R/check_dag.R @@ -307,7 +307,7 @@ print.check_dag <- function(x, ...) { # 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(out$current_adjustments %in% i) + !is.null(out$current_adjustments) && all(i %in% out$current_adjustments) }, logical(1)) # build message with check results for effects ----------------------- From 029604764dbb4d4f7f6060701d6f6cecc6eb688b Mon Sep 17 00:00:00 2001 From: Daniel Date: Sat, 10 Aug 2024 00:31:23 +0200 Subject: [PATCH 4/4] add tests --- tests/testthat/_snaps/check_dag.md | 51 ++++++++++++++++++++++++++++++ tests/testthat/test-check_dag.R | 28 +++++++++++++++- 2 files changed, 78 insertions(+), 1 deletion(-) diff --git a/tests/testthat/_snaps/check_dag.md b/tests/testthat/_snaps/check_dag.md index f3c4dfcbc..3a5c07da8 100644 --- a/tests/testthat/_snaps/check_dag.md +++ b/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. + + diff --git a/tests/testthat/test-check_dag.R b/tests/testthat/test-check_dag.R index 7d834b60a..efbffac30 100644 --- a/tests/testthat/test-check_dag.R +++ b/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)) +})