Skip to content

Commit

Permalink
https://github.com/easystats/easystats/issues/404
Browse files Browse the repository at this point in the history
  • Loading branch information
strengejacke committed May 16, 2024
1 parent 42d1d6f commit 24959dd
Show file tree
Hide file tree
Showing 5 changed files with 32 additions and 19 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Type: Package
Package: performance
Title: Assessment of Regression Models Performance
Version: 0.11.0.8
Version: 0.11.0.9
Authors@R:
c(person(given = "Daniel",
family = "Lüdecke",
Expand Down
4 changes: 4 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,10 @@
* Aliases `posterior_predictive_check()` and `check_posterior_predictions()` for
`check_predictions()` are deprecated.

* Arguments named `group` or `group_by` will be deprecated in a future release.
Please use `by` instead. This affects `check_heterogeneity_bias()` in
*performance*.

## General

* Improved documentation and new vignettes added.
Expand Down
27 changes: 17 additions & 10 deletions R/check_heterogeneity_bias.R
Original file line number Diff line number Diff line change
Expand Up @@ -8,9 +8,10 @@
#' @param select Character vector (or formula) with names of variables to select
#' that should be checked. If `x` is a mixed model object, this argument
#' will be ignored.
#' @param group Character vector (or formula) with the name of the variable that
#' @param by Character vector (or formula) with the name of the variable that
#' indicates the group- or cluster-ID. If `x` is a model object, this
#' argument will be ignored.
#' @param group Deprecated. Use `by` instead.
#'
#' @seealso
#' For further details, read the vignette
Expand All @@ -25,31 +26,37 @@
#' @examples
#' data(iris)
#' iris$ID <- sample(1:4, nrow(iris), replace = TRUE) # fake-ID
#' check_heterogeneity_bias(iris, select = c("Sepal.Length", "Petal.Length"), group = "ID")
#' check_heterogeneity_bias(iris, select = c("Sepal.Length", "Petal.Length"), by = "ID")
#' @export
check_heterogeneity_bias <- function(x, select = NULL, group = NULL) {
check_heterogeneity_bias <- function(x, select = NULL, by = NULL, group = NULL) {
## TODO: deprecate later
if (!is.null(group)) {
by <- group
}
if (insight::is_model(x)) {
group <- insight::find_random(x, split_nested = TRUE, flatten = TRUE)
if (is.null(group)) {
insight::format_error("Model is no mixed model. Please provide a mixed model, or a data frame and arguments `select` and `group`.") # nolint
by <- insight::find_random(x, split_nested = TRUE, flatten = TRUE)
if (is.null(by)) {
insight::format_error("Model is no mixed model. Please provide a mixed model, or a data frame and arguments `select` and `by`.") # nolint
}
my_data <- insight::get_data(x, source = "mf", verbose = FALSE)
select <- insight::find_predictors(x, effects = "fixed", component = "conditional", flatten = TRUE)
} else {
if (inherits(select, "formula")) {
select <- all.vars(select)
}
if (inherits(group, "formula")) {
group <- all.vars(group)
if (inherits(by, "formula")) {
by <- all.vars(by)
}
my_data <- x
}

unique_groups <- .n_unique(my_data[[group]])
combinations <- expand.grid(select, group)
unique_groups <- .n_unique(my_data[[by]])
combinations <- expand.grid(select, by)

result <- Map(function(predictor, id) {
# demean predictor

## FIXME: update argument name later!
d <- datawizard::demean(my_data, select = predictor, group = id, verbose = FALSE)

# get new names
Expand Down
8 changes: 5 additions & 3 deletions man/check_heterogeneity_bias.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

10 changes: 5 additions & 5 deletions tests/testthat/test-check_heterogeneity_bias.R
Original file line number Diff line number Diff line change
Expand Up @@ -2,29 +2,29 @@ test_that("check_heterogeneity_bias", {
data(iris)
set.seed(123)
iris$ID <- sample.int(4, nrow(iris), replace = TRUE) # fake-ID
out <- check_heterogeneity_bias(iris, select = c("Sepal.Length", "Petal.Length"), group = "ID")
out <- check_heterogeneity_bias(iris, select = c("Sepal.Length", "Petal.Length"), by = "ID")
expect_equal(out, c("Sepal.Length", "Petal.Length"), ignore_attr = TRUE)
expect_output(print(out), "Possible heterogeneity bias due to following predictors: Sepal\\.Length, Petal\\.Length")

out <- check_heterogeneity_bias(iris, select = ~ Sepal.Length + Petal.Length, group = ~ID)
out <- check_heterogeneity_bias(iris, select = ~ Sepal.Length + Petal.Length, by = ~ID)
expect_equal(out, c("Sepal.Length", "Petal.Length"), ignore_attr = TRUE)
expect_output(print(out), "Possible heterogeneity bias due to following predictors: Sepal\\.Length, Petal\\.Length")

m <- lm(Sepal.Length ~ Petal.Length + Petal.Width + Species + ID, data = iris)
expect_error(
check_heterogeneity_bias(m, select = c("Sepal.Length", "Petal.Length"), group = "ID"),
check_heterogeneity_bias(m, select = c("Sepal.Length", "Petal.Length"), by = "ID"),
regex = "no mixed model"
)

skip_if_not_installed("lme4")
m <- lme4::lmer(Sepal.Length ~ Petal.Length + Petal.Width + Species + (1 | ID), data = iris)
out <- check_heterogeneity_bias(m, select = c("Sepal.Length", "Petal.Length"), group = "ID")
out <- check_heterogeneity_bias(m, select = c("Sepal.Length", "Petal.Length"), by = "ID")
expect_equal(out, c("Petal.Length", "Petal.Width", "Species"), ignore_attr = TRUE)
expect_output(
print(out),
"Possible heterogeneity bias due to following predictors: Petal\\.Length, Petal\\.Width, Species"
)
out <- check_heterogeneity_bias(m, select = ~ Sepal.Length + Petal.Length, group = ~ID)
out <- check_heterogeneity_bias(m, select = ~ Sepal.Length + Petal.Length, by = ~ID)
expect_equal(out, c("Petal.Length", "Petal.Width", "Species"), ignore_attr = TRUE)
expect_output(
print(out),
Expand Down

0 comments on commit 24959dd

Please sign in to comment.