From bf0a365992794b7c6c9d886cab41e643fd1d4b12 Mon Sep 17 00:00:00 2001 From: Daniel Date: Tue, 11 Aug 2026 09:25:51 +0200 Subject: [PATCH 1/4] Create weighted data grids Fixes #642 --- DESCRIPTION | 2 +- R/get_marginalmeans.R | 20 ++++++++++++ tests/testthat/test-weighted_datagrid.R | 43 ++++++++++++++++++++++++- 3 files changed, 63 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3c2ea1328..cdf4f585d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: modelbased Title: Estimation of Model-Based Predictions, Contrasts and Means -Version: 0.16.0.13 +Version: 0.16.0.14 Authors@R: c(person(given = "Dominique", family = "Makowski", diff --git a/R/get_marginalmeans.R b/R/get_marginalmeans.R index cdd3ffa2d..01ca670f3 100644 --- a/R/get_marginalmeans.R +++ b/R/get_marginalmeans.R @@ -155,6 +155,26 @@ get_marginalmeans <- function( fun_args$type <- predict_args$predict } + ## TODO: document "fast" argument? + + # fast mode? + # --------------------------- + if (isTRUE(dots$fast)) { + # this overrides the existing data grid, if any. this means, "fast = TRUE" + # only works with marginal predictions (when `estimate` is "average" or + # "population"), not conditional, datagrid-based predictions (when + # `estimate` is "specific" or "typical") + if (estimate %in% c("specific", "typical")) { + insight::format_error( + "`fast` only works for marginal predictions, i.e. when `estimate` is set to \"average\" or \"population\"." + ) + } + fast_grid <- insight::get_datagrid(model, weighted = TRUE) + fun_args$newdata <- fast_grid + dots$weights <- fast_grid$Weight + dots$fast <- NULL + } + # weights? # --------------------------- diff --git a/tests/testthat/test-weighted_datagrid.R b/tests/testthat/test-weighted_datagrid.R index 2598909a6..48b148c13 100644 --- a/tests/testthat/test-weighted_datagrid.R +++ b/tests/testthat/test-weighted_datagrid.R @@ -2,7 +2,8 @@ skip_on_cran() skip_if_not_installed("marginaleffects") skip_if_not_installed("insight", minimum_version = "1.5.3") -test_that("weighted data grids work", { + +test_that("weighted data grids work for average", { data(penguins) # one factor @@ -17,5 +18,45 @@ test_that("weighted data grids work", { data = dg, weights = dg$Weight ) + emm3 <- estimate_means(model, "species", estimate = "average", fast = TRUE) + expect_equal(emm1$Mean, emm2$Mean, tolerance = 1e-4) + expect_equal(emm1$Mean, emm3$Mean, tolerance = 1e-4) +}) + + +test_that("weighted data grids work for population", { + data(penguins) + + # one factor + model <- lm(bill_len ~ species + sex + island, data = penguins) + dg <- insight::get_datagrid(model, weighted = TRUE) + + emm1 <- estimate_means(model, "species", estimate = "population") + emm2 <- estimate_means( + model, + "species", + estimate = "population", + data = dg, + weights = dg$Weight + ) + emm3 <- estimate_means(model, "species", estimate = "population", fast = TRUE) + + expect_equal(emm1$Mean, emm2$Mean, tolerance = 1e-4) + expect_equal(emm1$Mean, emm3$Mean, tolerance = 1e-4) +}) + + +test_that("weighted data grids errors for other estimate options", { + data(penguins) + + # one factor + model <- lm(bill_len ~ species + sex + island, data = penguins) + dg <- insight::get_datagrid(model, weighted = TRUE) + + expect_error( + estimate_means(model, "species", fast = TRUE), + regex = "`fast` only works for marginal", + fixed = TRUE + ) }) From 56cbc9cce0b0b9ab2e14ea25e6492db8f1992099 Mon Sep 17 00:00:00 2001 From: Daniel Date: Tue, 11 Aug 2026 12:15:35 +0200 Subject: [PATCH 2/4] improve fast mode --- R/get_marginalmeans.R | 26 +++++++-- tests/testthat/test-weighted_datagrid.R | 72 +++++++++++++++++++++++++ 2 files changed, 95 insertions(+), 3 deletions(-) diff --git a/R/get_marginalmeans.R b/R/get_marginalmeans.R index 01ca670f3..9775515c2 100644 --- a/R/get_marginalmeans.R +++ b/R/get_marginalmeans.R @@ -159,7 +159,7 @@ get_marginalmeans <- function( # fast mode? # --------------------------- - if (isTRUE(dots$fast)) { + if (isTRUE(dots$fast) || is.numeric(dots$fast)) { # this overrides the existing data grid, if any. this means, "fast = TRUE" # only works with marginal predictions (when `estimate` is "average" or # "population"), not conditional, datagrid-based predictions (when @@ -169,10 +169,30 @@ get_marginalmeans <- function( "`fast` only works for marginal predictions, i.e. when `estimate` is set to \"average\" or \"population\"." ) } - fast_grid <- insight::get_datagrid(model, weighted = TRUE) + # do we have bins? + n_bins <- dots$n_bins + # if not specified, we default to 5 bins, or to the value provided in "fast" + if (is.null(n_bins)) { + if (is.numeric(dots$fast)) { + n_bins <- dots$fast + } else { + n_bins <- 5 + } + } + # does model have weights? + model_weights <- insight::find_weights(model) + # if not, we default to TRUE to trigger weighted data grid. Else, we + # pass the name of the weights variable + if (is.null(model_weights)) { + model_weights <- TRUE + } + # create weighted (reduced) data grid + fast_grid <- insight::get_datagrid(model, n_bins = n_bins, weighted = model_weights) + # update newdata with reduced data grid for faster computation fun_args$newdata <- fast_grid dots$weights <- fast_grid$Weight - dots$fast <- NULL + # clean-up dots + dots$fast <- dots$n_bins <- NULL } # weights? diff --git a/tests/testthat/test-weighted_datagrid.R b/tests/testthat/test-weighted_datagrid.R index 48b148c13..36cf71472 100644 --- a/tests/testthat/test-weighted_datagrid.R +++ b/tests/testthat/test-weighted_datagrid.R @@ -25,6 +25,78 @@ test_that("weighted data grids work for average", { }) +test_that("weighted data grids work for average, binning of numerics", { + data(penguins) + + # one factor + model <- lm(bill_len ~ species + sex + island + body_mass, data = penguins) + dg <- insight::get_datagrid(model, weighted = TRUE) + + emm1 <- estimate_means(model, "species", estimate = "average") + emm2 <- estimate_means( + model, + "species", + estimate = "average", + data = dg, + weights = dg$Weight + ) + emm3 <- estimate_means(model, "species", estimate = "average", fast = TRUE) + + # need lower tolerance, due to binning not being exact to the empirical + # average of numeric values in the data + expect_equal(emm1$Mean, emm2$Mean, tolerance = 1e-3) + expect_equal(emm2$Mean, emm3$Mean, tolerance = 1e-5) + + dg <- insight::get_datagrid(model, n_bins = 15, weighted = TRUE) + emm2 <- estimate_means( + model, + "species", + estimate = "average", + data = dg, + weights = dg$Weight + ) + emm3 <- estimate_means(model, "species", estimate = "average", fast = 15) + + # need lower tolerance, due to binning not being exact to the empirical + # average of numeric values in the data, but tolerance is stricter + # due to more precise binning + expect_equal(emm1$Mean, emm2$Mean, tolerance = 1e-4) + expect_equal(emm2$Mean, emm3$Mean, tolerance = 1e-5) +}) + + +test_that("weighted data grids work for average and model weights, binning of numerics", { + set.seed(123) + d <- penguins + d$weights <- abs(rnorm(nrow(d), 1, 0.2)) + model <- lm(body_mass ~ species + sex + bill_len, data = d, weights = weights) + + dg <- insight::get_datagrid(model, weighted = "weights") + + emm1 <- estimate_means( + model, + "species", + estimate = "average", + data = dg, + weights = dg$Weight + ) + emm2 <- estimate_means(model, "species", estimate = "average", fast = TRUE) + expect_equal(emm1$Mean, emm2$Mean, tolerance = 1e-5) + + dg <- insight::get_datagrid(model, weighted = "weights", n_bins = 10) + + emm1 <- estimate_means( + model, + "species", + estimate = "average", + data = dg, + weights = dg$Weight + ) + emm2 <- estimate_means(model, "species", estimate = "average", fast = 10) + expect_equal(emm1$Mean, emm2$Mean, tolerance = 1e-5) +}) + + test_that("weighted data grids work for population", { data(penguins) From 99962baf37a56488640e9ef0ae495c73f26e5094 Mon Sep 17 00:00:00 2001 From: Daniel Date: Tue, 11 Aug 2026 12:23:27 +0200 Subject: [PATCH 3/4] ... --- tests/testthat/test-weighted_datagrid.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test-weighted_datagrid.R b/tests/testthat/test-weighted_datagrid.R index 36cf71472..d3abec316 100644 --- a/tests/testthat/test-weighted_datagrid.R +++ b/tests/testthat/test-weighted_datagrid.R @@ -2,7 +2,6 @@ skip_on_cran() skip_if_not_installed("marginaleffects") skip_if_not_installed("insight", minimum_version = "1.5.3") - test_that("weighted data grids work for average", { data(penguins) From 261753517c0bc85870e5b35ef8f11f0831c2836c Mon Sep 17 00:00:00 2001 From: Daniel Date: Tue, 11 Aug 2026 13:54:09 +0200 Subject: [PATCH 4/4] refactor --- R/get_marginalmeans.R | 90 ++++++++++++++++++++++++++----------------- 1 file changed, 55 insertions(+), 35 deletions(-) diff --git a/R/get_marginalmeans.R b/R/get_marginalmeans.R index 9775515c2..e87a82891 100644 --- a/R/get_marginalmeans.R +++ b/R/get_marginalmeans.R @@ -159,41 +159,17 @@ get_marginalmeans <- function( # fast mode? # --------------------------- - if (isTRUE(dots$fast) || is.numeric(dots$fast)) { - # this overrides the existing data grid, if any. this means, "fast = TRUE" - # only works with marginal predictions (when `estimate` is "average" or - # "population"), not conditional, datagrid-based predictions (when - # `estimate` is "specific" or "typical") - if (estimate %in% c("specific", "typical")) { - insight::format_error( - "`fast` only works for marginal predictions, i.e. when `estimate` is set to \"average\" or \"population\"." - ) - } - # do we have bins? - n_bins <- dots$n_bins - # if not specified, we default to 5 bins, or to the value provided in "fast" - if (is.null(n_bins)) { - if (is.numeric(dots$fast)) { - n_bins <- dots$fast - } else { - n_bins <- 5 - } - } - # does model have weights? - model_weights <- insight::find_weights(model) - # if not, we default to TRUE to trigger weighted data grid. Else, we - # pass the name of the weights variable - if (is.null(model_weights)) { - model_weights <- TRUE - } - # create weighted (reduced) data grid - fast_grid <- insight::get_datagrid(model, n_bins = n_bins, weighted = model_weights) - # update newdata with reduced data grid for faster computation - fun_args$newdata <- fast_grid - dots$weights <- fast_grid$Weight - # clean-up dots - dots$fast <- dots$n_bins <- NULL - } + + # create weighted (reduced) data grid, if "fast = TRUE" + tmp <- .create_weighted_datagrid( + model = model, + estimate = estimate, + fun_args = fun_args, + dots = dots + ) + # if we made any changes, update arguments + fun_args <- tmp$fun_args + dots <- tmp$dots # weights? # --------------------------- @@ -836,3 +812,47 @@ get_marginalmeans <- function( } } } + + +# create weighted data grid, for faster computation of predictions. Works best +# if reduced data grid is considerably smaller than the original model data, +# and is more efficient if model contains fewer categorical predictors. + +.create_weighted_datagrid <- function(model, estimate, fun_args, dots) { + if (isTRUE(dots$fast) || is.numeric(dots$fast)) { + # this overrides the existing data grid, if any. this means, "fast = TRUE" + # only works with marginal predictions (when `estimate` is "average" or + # "population"), not conditional, datagrid-based predictions (when + # `estimate` is "specific" or "typical") + if (estimate %in% c("specific", "typical")) { + insight::format_error( + "`fast` only works for marginal predictions, i.e. when `estimate` is set to \"average\" or \"population\"." + ) + } + # do we have bins? + n_bins <- dots$n_bins + # if not specified, we default to 5 bins, or to the value provided in "fast" + if (is.null(n_bins)) { + if (is.numeric(dots$fast)) { + n_bins <- dots$fast + } else { + n_bins <- 5 + } + } + # does model have weights? + model_weights <- insight::find_weights(model) + # if not, we default to TRUE to trigger weighted data grid. Else, we + # pass the name of the weights variable + if (is.null(model_weights)) { + model_weights <- TRUE + } + # create weighted (reduced) data grid + fast_grid <- insight::get_datagrid(model, n_bins = n_bins, weighted = model_weights) + # update newdata with reduced data grid for faster computation + fun_args$newdata <- fast_grid + dots$weights <- fast_grid$Weight + # clean-up dots + dots$fast <- dots$n_bins <- NULL + } + list(fun_args = fun_args, dots = dots) +}