re write doc and factor function

Author: mattansb

R/check_group_variation.R

@@ -9,53 +9,56 @@
 #'   `by`).
 #' @param by Character vector (or formula) with the name of the variable that
 #'   indicates the group- or cluster-ID. For cross-classified or nested designs,
-#'   `by` can also identify two or more variables as group- or cluster-IDs. If
-#'   the data is nested and should be treated as such, set `nested = TRUE`. Else,
-#'   if `by` defines two or more variables and `nested = FALSE`, a cross-classified
-#'   design is assumed.
-#'
-#'   For nested designs, `by` can be:
-#'   - a character vector with the name of the variable that indicates the
-#'     levels, ordered from *highest* level to *lowest* (e.g.
-#'     `by = c("L4", "L3", "L2")`.
-#'   - a character vector with variable names in the format `by = "L4/L3/L2"`,
-#'     where the levels are separated by `/`.
-#' @param only_balanced ...
-#' @param tolerance The amount of variation (calculated by `var()`, i.e. the
+#'   `by` can also identify two or more variables as group- or cluster-IDs.
+#' @param include_by When there is more than one grouping variable, should they
+#'   be check against each other?
+#' @param numeric_as_factor Should numeric variables be tested as factors?
+#' @param num_tolerance The amount of variation (calculated by `var()`, i.e. the
 #' variance of a variable) that is tolerated to indicate no within- or
 #' between-effect.
+#' @param fct_tolerance How should a non-numeric variable be identified as
+#'   varying only "within" a grouping variable? Options are:
+#'   - `"crossed"` - if all groups have all unique values of X.
+#'   - `"balanced"` - if all groups have all unique values of X, _with equal frequency_.
+
 #'
 #' @details
-#' This function calls [`datawizard::demean()`] to calculate the within- and
-#' between-effects of variables specified in `select`, based on the groups
-#' indicated in `by`. Then, the variance for each variable's within- and
-#' between-effect is calculated. If the variance is larger than `tolerance`,
-#' a within- or between-effect is detected.
+#' This function attempt to identify the hierarchical design of a dataset with
+#' respect to grouping variables (`by`).
+#'
+#' ## Numeric variables
+#' Numeric variables are portioned via [`datawizard::demean()`] to their within-
+#' and between-group components. Then, the variance for each variable's within-
+#' and between-group component is calculated. Variable with within-group
+#' variance larger than `num_tolerance` are labeled as _within_, variable with
+#' between-group variance larger than `num_tolerance` are labeled as _between_,
+#' and variables with both variances larger than `num_tolerance` are labeled as
+#' _both_.
+#' \cr\cr
+#' Setting `numeric_as_factor = TRUE` causes numeric variables to be tested
+#' using the following criteria.
+#'
+#' ## Non-numeric variables
+#' These variables can have one of the following 4 labels:
+#' - _between_ - the variable is fixed (has exactly one unique, constant value) for each group.
+#' - _nested_ - the variable varies within each group, with each group having their own set of
+#'   unique levels of the variable.
+#' - _within_ - the variable is _crossed_ with the grouping variable - each value appear
+#'   within each group. The `fct_tolerance` argument controls if full balance is also required.
+#' - _both_ - the variable is partially nested within the grouping variable (or, when
+#'   `fct_tolerance = "balanced"` the variable is fully crossed, but not perfectly balanced).
 #'
-#' @return A list with at most three elements, `within`, `between`, and `both`,
-#' where each element contains the name of variables that have one of these
-#' effects.
+#' @return A data frame with group, variable, and type columns.
 #'
 #' @examples
-#' set.seed(1234)
-#' dat <- data.frame(
-#'   id = rep(letters, each = 3),
-#'   between_num = rep(rnorm(26), each = 3),
-#'   within1_num = rep(rnorm(3), times = 26),
-#'   within2_num = rep(rnorm(3), times = 26),
-#'   both_num = rnorm(3 * 26)
-#' )
-#' check_group_variation(
-#'   dat,
-#'   select = c("between_num", "within1_num", "within2_num", "both_num"),
-#'   by = "id"
-#' )
 #' @export
 check_group_variation <- function(x,
                                   select = NULL,
                                   by = NULL,
-                                  tolerance = 1e-4,
-                                  only_balanced = TRUE) {
+                                  include_by = FALSE,
+                                  numeric_as_factor = FALSE,
+                                  num_tolerance = 1e-4,
+                                  fct_tolerance = "crossed") {
   insight::check_if_installed("datawizard", minimum_version = "0.12.0")
 
   if (inherits(select, "formula")) {
@@ -80,6 +83,14 @@ check_group_variation <- function(x,
     select <- setdiff(colnames(x), by)
   }
 
+  if (include_by && (length(by) > 1L)) {
+    select <- c(by, select)
+  }
+
+  if (numeric_as_factor) {
+    x[select] <- lapply(x[select], as.factor)
+  }
+
   # create all combinations that should be checked
   combinations <- expand.grid(
     variable = select,
@@ -95,8 +106,8 @@ check_group_variation <- function(x,
       x,
       combinations[i, "group"],
       combinations[i, "variable"],
-      tolerance = tolerance,
-      only_balanced = only_balanced
+      num_tolerance = num_tolerance,
+      fct_tolerance = fct_tolerance
     )
   }
 
@@ -112,33 +123,35 @@ check_group_variation <- function(x,
 
 #' @export
 print.check_group_variation <- function(x, ...) {
-  if (insight::n_unique(x$group) > 1L) {
-    cat(insight::export_table(
-      x,
-      caption = c("Check group variation", "blue"),
-      by = "group"
-    ))
-  } else {
-    x_new <- x
-    x_new$group <- NULL
-    cat(insight::export_table(
-      x_new,
-      caption = c(sprintf("Check %s variation", x$group[1]), "blue")
-    ))
-  }
-
-  return(invisible(x))
+  x_orig <- x
+
+  cap <- "Check group variation"
+  by <- "group"
+
+  if (insight::n_unique(x$group) == 1L) {
+    x$group <- NULL
+    cap <- sprintf("Check %s variation", x_orig$group[1])
+    by <- NULL
+  }
+
+  cat(insight::export_table(x, caption = c(cap, "blue"), by = by, ...))
+
+  return(invisible(x_orig))
 }
 
 
 # utils -------------------------------------------------------------
 
 .check_nested <- function(data, by, predictor, ...) {
+  if (insight::n_unique(data[[predictor]]) == 1L) {
+    return(NA_character_)
+  }
+
   UseMethod(".check_nested", data[[predictor]])
 }
 
 
-.check_nested.numeric <- function(data, by, predictor, tolerance = 1e-05, ...) {
+.check_nested.numeric <- function(data, by, predictor, num_tolerance = 1e-05, ...) {
   # demean predictor
   d <- datawizard::demean(
     data,
@@ -152,41 +165,83 @@ print.check_group_variation <- function(x, ...) {
   within_name <- paste0(predictor, "_within")
   between_name <- paste0(predictor, "_between")
 
-  is_between <- var(d[[between_name]], na.rm = TRUE) > tolerance
-  is_within <- var(d[[within_name]], na.rm = TRUE) > tolerance
+  is_between <- var(d[[between_name]], na.rm = TRUE) > num_tolerance
+  is_within <- var(d[[within_name]], na.rm = TRUE) > num_tolerance
   is_both <- is_between && is_within
 
-  if (is_both) return("both")
-  if (is_between) return("between")
-  if (is_within) return("within")
-  NULL
+  if (is_both) {
+    return("both")
+  }
+  if (is_between) {
+    return("between")
+  }
+  if (is_within) {
+    return("within")
+  }
+
+  NA_character_
 }
 
 
-.check_nested.default <- function(data, by, predictor, only_balanced = TRUE, ...) {
+.check_nested.default <- function(data, by, predictor, fct_tolerance = c("crossed", "balanced"), ...) {
+  fct_tolerance <- match.arg(fct_tolerance)
+
   group <- data[[by]]
   variable <- data[[predictor]]
 
   complete <- stats::complete.cases(group, variable)
   group <- as.factor(group[complete])
   variable <- variable[complete]
 
+  # Is the variable fixed for each group?
   n_uniques <- tapply(variable, group, insight::n_unique)
   is_between <- all(n_uniques == 1L)
-  if (is_between) return("between")
+  if (is_between) {
+    return("between")
+  }
+
+  # Is the variable nested within each group?
+  if (insight::check_if_installed("Matrix", reason = "for checking nested designs")) {
+    # code from lme4::isNested
+    f1 <- as.factor(variable)
+    f2 <- as.factor(group)
+    k <- length(levels(f1))
+    sm <- as(
+      new("ngTMatrix",
+        i = as.integer(f2) - 1L,
+        j = as.integer(f1) - 1L,
+        Dim = c(length(levels(f2)), k)
+      ),
+      "CsparseMatrix"
+    )
+    if (all(sm@p[2:(k + 1L)] - sm@p[1:k] <= 1L)) {
+      return("nested")
+    }
+  }
 
-  if (!insight::has_single_value(is_between)) return("both")
+  # If each group has a different number of unique values,
+  # then it is partially nested/crossed.
+  if (!insight::has_single_value(n_uniques)) {
+    return("both")
+  }
 
+  # Is the variable crossed?
   variable_levels <- unique(variable)
   has_all <- tapply(variable, group, function(v) all(variable_levels %in% v))
-  if (!all(has_all)) return("both")
+  if (!all(has_all)) {
+    return("both")
+  }
 
-  if (only_balanced) {
-    tab <- table(variable, group)
-    is_balanced <- all(apply(tab, 2, insight::has_single_value))
-    if (!is_balanced) {
-      return("both")
-    }
+  if (fct_tolerance == "crossed") {
+    return("within")
+  }
+
+  # Is the variable crossed and balanced?
+  tab <- table(variable, group)
+  is_balanced <- all(apply(tab, 2, insight::has_single_value))
+  if (!is_balanced) {
+    return("both")
   }
+
   return("within")
 }