Add POOR

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: performance
 Title: Assessment of Regression Models Performance
-Version: 0.17.1.9
+Version: 0.17.1.10
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

NAMESPACE

@@ -370,6 +370,7 @@ S3method(print,performance_model)
 S3method(print,performance_mor)
 S3method(print,performance_omega)
 S3method(print,performance_pcp)
+S3method(print,performance_poor)
 S3method(print,performance_pp_check)
 S3method(print,performance_rmse)
 S3method(print,performance_roc)
@@ -666,6 +667,7 @@ export(performance_mae)
 export(performance_mor)
 export(performance_mse)
 export(performance_pcp)
+export(performance_poor)
 export(performance_reliability)
 export(performance_rmse)
 export(performance_roc)

NEWS.md

@@ -2,8 +2,9 @@
 
 ## Changes
 
-* New functions `performance_mor()` and `performance_ior()` to calculate median
-  odds ratios and interval odds ratios for logistic multilevel regression.
+* New functions `performance_mor()`, `performance_poor()` and `performance_ior()`
+  to calculate median odds ratios, proportions of opposed odds ratios, and
+  interval odds ratios for logistic multilevel regression.
 
 * `check_group_variation()` now returns a numeric effect size of the grouping
   variable's predictive association strength.

R/performance_ior.R

@@ -38,11 +38,11 @@
 #' )
 #' performance_ior(m)
 #'
-#' m <- lme4::glmer(
+#' m <- suppressWarnings(lme4::glmer(
 #'   high_reaction ~ Days + (1 | mygrp) + (1 | Subject),
 #'   data = sleepstudy,
 #'   family = "binomial"
-#' )
+#' ))
 #' performance_ior(m)
 #' @export
 performance_ior <- function(x) {

R/performance_mor.R

@@ -35,11 +35,11 @@
 #' )
 #' performance_mor(m)
 #'
-#' m <- lme4::glmer(
+#' m <- suppressWarnings(lme4::glmer(
 #'   high_reaction ~ Days + (1 | mygrp) + (1 | Subject),
 #'   data = sleepstudy,
 #'   family = "binomial"
-#' )
+#' ))
 #' performance_mor(m)
 #'
 #' @references

R/performance_poor.R

@@ -0,0 +1,84 @@
+#' @title Proportion of Opposed Odds Ratios
+#' @name performance_poor
+#'
+#' @description
+#' This function quantifies the extent to which the residual (unexplained)
+#' stratum heterogeneity dominates the estimated fixed effect of a group- or
+#' stratum-level characteristic. This measure represents the percentage of all
+#' hypothetical, pairwise comparisons in which the individual-level effect is in
+#' the opposite direction of the estimated average odds ratio (OR).
+#'
+#' @param x A (logistic) multilevel model.
+#'
+#' @details
+#' The POOR value always ranges between 0% and 50%.
+#' - 0%: Perfect homogeneity. Every single randomly selected pair of
+#'   observations shows an effect in the same direction as the overall OR.
+#' - 50%: Total heterogeneity (pure chance). In exactly half of the cases, the
+#'   effect is reversed; the stratum characteristic possesses no orderly
+#'   predictive power whatsoever, as it is completely dominated by the
+#'   unexplained stratum variance.
+#'
+#' Practical Significance: A high POOR value (e.g., > 30%) serves as a strong
+#' warning to researchers against making overgeneralized statements about the
+#' utility of a stratum characteristic, as the average OR masks massive
+#' internal heterogeneity.
+#'
+#' @return
+#' A data frame with the parameter names and their POOR estimates.
+#'
+#' @examplesIf all(insight::check_if_installed(c("lme4", "datawizard"), quietly = TRUE))
+#' data(sleepstudy, package = "lme4")
+#' sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE)
+#' sleepstudy$high_reaction <- as.factor(datawizard::categorize(sleepstudy$Reaction))
+#'
+#' m <- lme4::glmer(
+#'   high_reaction ~ Days + (1 | Subject),
+#'   data = sleepstudy,
+#'   family = "binomial"
+#' )
+#' performance_poor(m)
+#'
+#' m <- suppressWarnings(lme4::glmer(
+#'   high_reaction ~ Days + (1 | mygrp) + (1 | Subject),
+#'   data = sleepstudy,
+#'   family = "binomial"
+#' ))
+#' performance_poor(m)
+#' @export
+performance_poor <- function(x) {
+  model_info <- insight::model_info(x)
+
+  valid_ior <- .valid_roc_models(x) &&
+    isTRUE(model_info$is_logit) &&
+    isTRUE(model_info$is_binomial) &&
+    insight::is_mixed_model(x)
+
+  if (!valid_ior) {
+    insight::format_error("The supplied model needs to be a logistic multilevel model.")
+  }
+
+  v_a <- insight::get_variance_intercept(x)
+  params <- insight::get_parameters(x, effects = "fixed")
+
+  out <- do.call(
+    rbind,
+    lapply(names(v_a), function(tau) {
+      data.frame(
+        Parameter = params$Parameter,
+        Group = gsub("var.intercept.", "", tau, fixed = TRUE),
+        POOR = stats::pnorm(-abs(params$Estimate) / sqrt(2 * v_a[tau])),
+        stringsAsFactors = FALSE
+      )
+    })
+  )
+
+  class(out) <- c("performance_poor", "data.frame")
+  out
+}
+
+#' @export
+print.performance_poor <- function(x, ...) {
+  cat(insight::export_table(x, caption = "Proportion of Opposed Odds Ratios"))
+  invisible(x)
+}

tests/testthat/test-performance_mor.R

@@ -4,7 +4,7 @@
 test_that("performance_mor", {
   data(sleepstudy, package = "lme4")
   set.seed(123)
   sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE)
   sleepstudy$high_reaction <- as.factor(datawizard::categorize(sleepstudy$Reaction))
 
   m <- lme4::glmer(
@@ -20,11 +20,11 @@
     ignore_attr = TRUE
   )
 
-  m <- lme4::glmer(
+  m <- suppressWarnings(lme4::glmer(
     high_reaction ~ Days + (1 | mygrp) + (1 | Subject),
     data = sleepstudy,
     family = "binomial"
-  )
+  ))
   out <- performance_mor(m)
   expect_equal(
     out,

tests/testthat/test-performance_poor.R

@@ -0,0 +1,62 @@
+skip_if_not_installed("lme4")
+skip_if_not_installed("datawizard")
+
+test_that("performance_poor", {
+  data(sleepstudy, package = "lme4")
+  set.seed(123)
+  sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE)
+  sleepstudy$high_reaction <- as.factor(datawizard::categorize(sleepstudy$Reaction))
+
+  m <- lme4::glmer(
+    high_reaction ~ Days + (1 | Subject),
+    data = sleepstudy,
+    family = "binomial"
+  )
+  out <- performance_poor(m)
+  # fmt: skip
+  expect_equal(
+    out,
+    data.frame(
+      Parameter = c("(Intercept)", "Days"),
+      Group = c("Subject", "Subject"),
+      POOR = c(0.192778797972706, 0.426136228315004),
+      stringsAsFactors = FALSE
+    ),
+    tolerance = 1e-4,
+    ignore_attr = TRUE
+  )
+
+  m <- suppressWarnings(lme4::glmer(
+    high_reaction ~ Days + (1 | mygrp) + (1 | Subject),
+    data = sleepstudy,
+    family = "binomial"
+  ))
+  out <- performance_poor(m)
+  # fmt: skip
+  expect_equal(
+    out,
+    data.frame(
+      Parameter = c("(Intercept)", "Days", "(Intercept)", "Days"),
+      Group = c("Subject", "Subject", "mygrp", "mygrp"),
+      POOR = c(0.192779101384865, 0.426136323408472, 0, 0),
+      stringsAsFactors = FALSE
+    ),
+    tolerance = 1e-4,
+    ignore_attr = TRUE
+  )
+
+  # errors
+  m <- glm(high_reaction ~ Days, data = sleepstudy, family = "binomial")
+  expect_error(
+    performance_poor(m),
+    "The supplied model needs to be",
+    fixed = TRUE
+  )
+
+  m <- lme4::lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy)
+  expect_error(
+    performance_poor(m),
+    "The supplied model needs to be",
+    fixed = TRUE
+  )
+})