Add Mantel-Fleiss criterion function mantel_fleiss_crit().

NAMESPACE

@@ -248,6 +248,7 @@ export(labels_use_control)
 export(level_order)
 export(logistic_regression_cols)
 export(logistic_summary_by_flag)
+export(mantel_fleiss_crit)
 export(month2day)
 export(or_clogit)
 export(or_glm)

NEWS.md

@@ -1,6 +1,8 @@
 # tern 0.9.11.9000
 
 ### Enhancements
+* Added `mantel_fleiss_crit()` to check the Mantel-Fleiss criterion
+  for stratified 2 x 2 contingency tables.(#1512)
 * Updated `g_forest()` to support point estimates and confidence intervals
   stored in a single column. (#1499)
 * Added the `exclude_rows` argument to `g_forest()` to allow excluding selected

R/prop_diff_test.R

@@ -481,3 +481,137 @@ prop_fisher <- function(tbl, alternative = c("two.sided", "less", "greater")) {
   tbl <- tbl[, c("TRUE", "FALSE")]
   stats::fisher.test(tbl, alternative = alternative)$p.value
 }
+
+#' @title Check the Mantel-Fleiss Criterion
+#'
+#' @description `r lifecycle::badge("stable")`
+#'
+#' Checks the Mantel-Fleiss criterion for stratified 2 x 2 contingency tables.
+#'
+#' @details
+#' The Mantel-Fleiss statistic is calculated as
+#'
+#' \deqn{
+#' MF = \min\left(
+#' [\sum_h m_{11h} - \sum_h {(n_{11h})}_L],\
+#' [\sum_h {(n_{11h})}_U - \sum_h m_{11h}]
+#' \right),
+#' }
+#'
+#' where \eqn{h} indexes the non-empty strata. For each stratum \eqn{h}, the
+#' expected frequency of cell \eqn{(1, 1)} in table \eqn{h}, under the
+#' hypothesis of no association between group and response, is
+#'
+#' \deqn{
+#' m_{11h} = \frac{n_{1.h} n_{.1h}}{n_h}.
+#' }
+#'
+#' The lower and upper bounds for \eqn{n_{11h}}, given the marginal totals,
+#' are:
+#'
+#' \deqn{
+#' {(n_{11h})}_L = \max(0, n_{1.h} - n_{.2h}),
+#' }
+#' \deqn{
+#' {(n_{11h})}_U = \min(n_{.1h}, n_{1.h}).
+#' }
+#'
+#' The Mantel-Fleiss criterion is satisfied when \eqn{MF \ge 5}.
+#'
+#' Strata with all cell counts equal to zero are excluded from the
+#' calculation. If all strata contain zero observations, there are no
+#' non-empty strata over which to calculate the Mantel-Fleiss statistic, and
+#' the statistic is therefore undefined. In this case, the function returns
+#' `NA`.
+#'
+#' @param tbl (`array`)\cr
+#'   A three-dimensional contingency table containing the counts for each
+#'   combination of group, response, and stratum. The first two dimensions
+#'   must correspond to the two variables defining the 2 x 2 contingency
+#'   table (group and response), in either order. The third dimension must
+#'   correspond to the strata. The first two dimensions must each have exactly
+#'   two levels. All cell values must be finite, non-missing integer counts.
+#' @param include_value (`logical(1)`)\cr
+#'   Whether to include the calculated Mantel-Fleiss statistic as an attribute
+#'   of the result.
+#'
+#' @return A logical value indicating whether the Mantel-Fleiss criterion
+#' is satisfied. If `include_value = TRUE`, the result also contains a
+#' value attribute with the calculated Mantel-Fleiss statistic. If there
+#' are no non-empty strata, the result is `NA` and the value attribute is
+#' `NA_real_`.
+#'
+#' @author WW
+#'
+#' @examples
+#' set.seed(123)
+#' n <- 40
+#'
+#' grp <- factor(sample(c("Active", "Control"), n, replace = TRUE))
+#' rsp <- sample(c(TRUE, FALSE), n, replace = TRUE)
+#' strata1 <- factor(sample(c("A", "B"), n, replace = TRUE))
+#' strata2 <- factor(sample(c("x", "y"), n, replace = TRUE))
+#' strata <- interaction(strata1, strata2)
+#'
+#' tbl <- table(grp, rsp, strata)
+#' tbl
+#'
+#' mantel_fleiss_crit(tbl)
+#' mantel_fleiss_crit(tbl, include_value = TRUE)
+#'
+#' @references
+#' Mantel, N., and Fleiss, J. L. (1980).
+#' Minimum Expected Cell Size Requirements for the Mantel-Haenszel
+#' One-Degree-of-Freedom Chi-Square Test and a Related Rapid Procedure.
+#' \emph{American Journal of Epidemiology}, 112(1), 129--134.
+#'
+#' @export
+mantel_fleiss_crit <- function(tbl, include_value = FALSE) {
+  checkmate::assert_array(tbl, mode = "integerish", any.missing = FALSE, d = 3L)
+  checkmate::assert_true(all(tbl >= 0L))
+  checkmate::assert_true(all(is.finite(tbl)))
+  checkmate::assert_true(nrow(tbl) == 2L)
+  checkmate::assert_true(ncol(tbl) == 2L)
+  checkmate::assert_flag(include_value)
+
+  # Drop strata with no observations.
+  tbl <- tbl[, , apply(tbl, 3L, sum) > 0, drop = FALSE]
+
+  # Add marginal totals over the group and response dimensions,
+  # retaining the stratum dimension.
+  tbl_mrgn <- stats::addmargins(tbl, margin = 1:2)
+
+  # If there are no non-empty strata, the Mantel-Fleiss criterion is undefined
+  # because there are no strata over which to calculate it.
+  if (dim(tbl)[3L] == 0L) {
+    is_satisfied <- NA
+    if (include_value) {
+      attr(is_satisfied, "value") <- NA_real_
+    }
+    return(is_satisfied)
+  }
+
+  n_1dot <- tbl_mrgn[1L, "Sum", ]
+  n_dot1 <- tbl_mrgn["Sum", 1L, ]
+  n_dot2 <- tbl_mrgn["Sum", 2L, ]
+  n <- tbl_mrgn["Sum", "Sum", ]
+
+  # Expected value of n_11 under the hypothesis of no association
+  # between group and response (within a given stratum).
+  m_11 <- (n_1dot * n_dot1) / n
+  # Lower and upper bounds for n_11 given the marginal totals (within a given stratum).
+  n_11_lwr <- pmax(0L, n_1dot - n_dot2)
+  n_11_upr <- pmin(n_dot1, n_1dot)
+
+  mf_value <- min(
+    sum(m_11) - sum(n_11_lwr),
+    sum(n_11_upr) - sum(m_11)
+  )
+
+  is_satisfied <- mf_value >= 5
+  if (include_value) {
+    attr(is_satisfied, "value") <- mf_value
+  }
+
+  is_satisfied
+}

_pkgdown.yml

@@ -113,6 +113,7 @@ reference:
       - -h_xticks
       - -prop_diff
       - check_diff_prop_ci
+      - mantel_fleiss_crit
 
   - title: rtables Helper Functions
     desc: These functions help to work with the `rtables` package and may be

inst/WORDLIST

@@ -15,6 +15,7 @@ CMH
 CQ
 Clopper
 Coull
+Fleiss
 Haenszel
 Hauck
 Hilferty