Merge branch 'main' into causual_inference_vignette

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: modelbased
 Title: Estimation of Model-Based Predictions, Contrasts and Means
-Version: 0.9.0.26
+Version: 0.9.0.27
 Authors@R:
     c(person(given = "Dominique",
              family = "Makowski",

R/format.R

@@ -288,24 +288,51 @@ format.marginaleffects_contrasts <- function(x, model = NULL, p_adjust = NULL, c
       # levels correctly, we now replace levels with a special "token", and later
       # replace those tokens with the original levels again
 
-      # extract all comparison levels
-      all_levels <- unlist(lapply(dgrid[contrast], function(i) as.character(unique(i))), use.names = FALSE)
+      # extract all comparison levels, separately for numerics and factors/character
+      # we have to do this for numeric values and factors&character separately,
+      # because we need different regular expressions when "escaping" the "levels"
+      # of our focal predictors. we do this escaping because we want each
+      # contrasted level-combination in an own column.
+      all_levels <- all_num_levels <- NULL
+      # find numeric focal terms
+      numeric_focals <- vapply(dgrid[contrast], is.numeric, logical(1))
+      # extract levels of non-numerics
+      if (!all(numeric_focals)) {
+        all_levels <- unlist(lapply(
+          dgrid[contrast[!numeric_focals]],
+          function(i) as.character(unique(i))
+        ), use.names = FALSE)
+      }
+      # extract levels of non-numerics
+      if (any(numeric_focals)) {
+        all_num_levels <- unlist(lapply(
+          dgrid[contrast[numeric_focals]],
+          function(i) as.character(unique(i))
+        ), use.names = FALSE)
+      }
       # create replacement vector
-      replace_levels <- NULL
+      replace_levels <- replace_num_levels <- NULL
       # this looks strange, but we need to make sure we have unique tokens that
       # do not contain any letters or numbers, or similar characters that may
       # appear as a single level in the data. thus, we use a sequence of "~"
       # characters, which are unlikely to appear in the data
       for (i in seq_along(all_levels)) {
         replace_levels <- c(replace_levels, paste0("#", paste(rep_len("~", i), collapse = ""), "#"))
       }
+      for (i in seq_along(all_num_levels)) {
+        replace_num_levels <- c(replace_num_levels, paste0("#", paste(rep_len("@", i), collapse = ""), "#"))
+      }
 
       # replace all comparison levels with tokens
       params[] <- lapply(params, function(comparison_pair) {
+        for (j in seq_along(all_num_levels)) {
+          comparison_pair <- sub(all_num_levels[j], replace_num_levels[j], comparison_pair)
+        }
         for (j in seq_along(all_levels)) {
           comparison_pair <- sub(paste0("\\<", all_levels[j], "\\>"), replace_levels[j], comparison_pair)
         }
-        comparison_pair
+        # remove multiple spaces
+        gsub("[[:space:]]{2,}", " ", comparison_pair)
       })
 
       # we now have a data frame with each comparison-pairs as single column.
@@ -327,6 +354,9 @@ format.marginaleffects_contrasts <- function(x, model = NULL, p_adjust = NULL, c
         for (j in seq_along(all_levels)) {
           comparison_pair <- sub(replace_levels[j], all_levels[j], comparison_pair, fixed = TRUE)
         }
+        for (j in seq_along(all_num_levels)) {
+          comparison_pair <- sub(replace_num_levels[j], all_num_levels[j], comparison_pair, fixed = TRUE)
+        }
         comparison_pair
       })
     } else {

tests/testthat/_snaps/estimate_contrasts.md

@@ -886,3 +886,33 @@
       Predictors contrasted: grp, time=2
       p-values are uncorrected.
 
+# estimate_contrast, slopes with emmeans
+
+    Code
+      print(out, table_width = Inf)
+    Output
+      Marginal Contrasts Analysis
+      
+      Level1    | Level2    | Difference |        95% CI |     p
+      ----------------------------------------------------------
+      0, 0.725  | 0, -2.012 |       1.12 | [0.37,  3.43] | 0.839
+      0, 3.463  | 0, -2.012 |       1.26 | [0.14, 11.76] | 0.839
+      1, -2.012 | 0, -2.012 |       1.00 | [0.35,  2.82] | 0.999
+      1, 0.725  | 0, -2.012 |       1.12 | [0.23,  5.43] | 0.887
+      1, 3.463  | 0, -2.012 |       1.26 | [0.10, 15.76] | 0.858
+      0, 3.463  | 0, 0.725  |       1.12 | [0.37,  3.43] | 0.839
+      1, -2.012 | 0, 0.725  |       0.89 | [0.20,  3.87] | 0.877
+      1, 0.725  | 0, 0.725  |       1.00 | [0.35,  2.82] | 0.999
+      1, 3.463  | 0, 0.725  |       1.12 | [0.23,  5.43] | 0.887
+      1, -2.012 | 0, 3.463  |       0.79 | [0.07,  8.71] | 0.849
+      1, 0.725  | 0, 3.463  |       0.89 | [0.20,  3.87] | 0.877
+      1, 3.463  | 0, 3.463  |       1.00 | [0.35,  2.82] | 0.999
+      1, 0.725  | 1, -2.012 |       1.12 | [0.37,  3.43] | 0.839
+      1, 3.463  | 1, -2.012 |       1.26 | [0.14, 11.76] | 0.839
+      1, 3.463  | 1, 0.725  |       1.12 | [0.37,  3.43] | 0.839
+      
+      Variable predicted: outcome
+      Predictors contrasted: var_binom, var_cont
+      p-values are uncorrected.
+      Contrasts are on the link-scale.
+

tests/testthat/test-estimate_contrasts.R

@@ -84,7 +84,11 @@ test_that("estimate_contrasts - Frequentist, One factor and one continuous", {
   expect_identical(dim(estim), c(3L, 9L))
   estim <- estimate_contrasts(model, contrast = "Petal.Length=c(2.3, 3)", backend = "marginaleffects")
   expect_identical(dim(estim), c(1L, 9L))
+  expect_named(estim, c("Level1", "Level2", "Difference", "SE", "CI_low", "CI_high", "t", "df", "p"))
+  expect_identical(as.character(estim$Level1), "3")
   estim <- estimate_contrasts(model, contrast = "Petal.Length=c(2, 3, 4)", backend = "marginaleffects")
+  expect_named(estim, c("Level1", "Level2", "Difference", "SE", "CI_low", "CI_high", "t", "df", "p"))
+  expect_identical(as.character(estim$Level1), c("3", "4", "4"))
   expect_identical(dim(estim), c(3L, 9L))
 })
 
@@ -754,3 +758,30 @@ test_that("estimate_contrast, slopes with emmeans", {
   expect_equal(out$Difference, c(-0.12981, 0.04095, 0.17076), tolerance = 1e-4)
   expect_identical(as.character(out$Level1), c("setosa", "setosa", "versicolor"))
 })
+
+
+test_that("estimate_contrast, slopes with emmeans", {
+  set.seed(123)
+  dat <- data.frame(
+    outcome = rbinom(n = 100, size = 1, prob = 0.35),
+    var_binom = as.factor(rbinom(n = 100, size = 1, prob = 0.2)),
+    var_cont = rnorm(n = 100, mean = 10, sd = 7)
+  )
+  dat$var_cont <- datawizard::standardize(dat$var_cont)
+
+  m1 <- glm(
+    outcome ~ var_binom + var_cont,
+    data = dat,
+    family = binomial(link = "logit")
+  )
+
+  # range of values
+  out <- estimate_contrasts(
+    m1,
+    c("var_binom", "var_cont"),
+    predict = "link",
+    transform = exp,
+    length = 3
+  )
+  expect_snapshot(print(out, table_width = Inf))
+})