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", diff --git a/R/check_dag.R b/R/check_dag.R index 0f29863af..b78090a6f 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(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 { 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)) +})