R/utils_compositions.R

In dyadMLM: Tools for Dyadic Multilevel Models

#############################################################################
# CONSTANTS
############################################################################

# Package-wide separator for composition labels.
dyad_composition_sep <- "_x_"

# Separator for appending a member role to a dyad composition label.
dyad_composition_role_sep <- "_"

# Label used when no role column is supplied.
dyad_assumed_exchangeable_label <- "assumed_exchangeable"

# Prefix reserved for temporary implementation columns.
dyad_reserved_prefix <- ".dy_"

# Retained columns use "." so model formulas remain concise.
dyad_retained_prefix <- "."

# Fixed retained and temporary column names used throughout preparation.
dyad_composition_col <- paste0(dyad_retained_prefix, "composition")
dyad_composition_role_col <- paste0(dyad_retained_prefix, "composition_role")
dyad_type_col <- paste0(dyad_reserved_prefix, "dyad_type")
dyad_type_source_col <- paste0(dyad_reserved_prefix, "dyad_type_source")
dyad_raw_composition_col <- paste0(dyad_reserved_prefix, "raw_composition")
dyad_pool_member_col <- paste0(dyad_reserved_prefix, "pool_member")
dyad_resolved_role_col <- paste0(dyad_reserved_prefix, "resolved_role")
dyad_diff_col <- paste0(dyad_reserved_prefix, "diff")
dyad_arbitrary_role_col <- paste0(dyad_reserved_prefix, "arbitrary_role")
dyad_dsm_role_contrast_col <- paste0(dyad_retained_prefix, "dsm_role_contrast")

############################################################################
# HELPER FUNCTIONS
###########################################################################

#' Create a canonical dyad composition label
#'
#' Sorts role labels before pasting them so composition labels do not depend on
#' row order.
#'
#' @param roles A vector of role labels.
#' @param sep Separator used between label components.
#'
#' @return A single composition label.
#' @keywords internal
canonical_composition <- function(roles, sep = dyad_composition_sep) {
  paste(sort(as.character(roles)), collapse = sep)
}


#' @rdname canonical_composition
#' @param composition A composition label.
#' @param role A row-level role label.
#' @keywords internal
composition_role_label <- function(composition, role, sep = dyad_composition_role_sep) {
  paste(as.character(composition), as.character(role), sep = sep)
}


#' Attach current dyad counts to stored composition metadata
#'
#' @param data A prepared `dyadMLM_data` object.
#'
#' @return The stored composition metadata with counts from the current rows,
#'   or `NULL` if the required columns are unavailable.
#' @noRd
dyad_compositions_with_current_counts <- function(data) {
  meta_data <- attr(data, "dyadMLM")
  required_columns <- c(meta_data$dyad, dyad_composition_col)

  if (!all(required_columns %in% names(data))) {
    return(NULL)
  }

  # Count each identifiable dyad once, regardless of member rows or occasions.
  current_composition_counts <- tibble::tibble(
    dyad = data[[meta_data$dyad]],
    composition = data[[dyad_composition_col]]
  ) |>
    dplyr::filter(!is.na(.data$dyad)) |>
    dplyr::distinct() |>
    dplyr::count(.data$composition, name = "n_dyads")

  # Retain how each composition was prepared, but replace its original count.
  composition_metadata <- meta_data$dyad_compositions
  composition_metadata$n_dyads <- NULL

  dplyr::inner_join(
    composition_metadata,
    current_composition_counts,
    by = "composition"
  )
}


#' Create safe suffixes for generated dyadMLM columns
#'
#' @param labels Labels that will be used to build generated column names.
#'
#' @return A named character vector. Names are the original labels; values are
#'   sanitized column-name suffixes.
#' @keywords internal
make_dyad_suffixes <- function(labels, label_type = "labels",
                                   rename_hint = "role or composition labels") {
  labels <- unique(as.character(labels))
  suffixes <- gsub("[^[:alnum:]_]+", "_", labels)

  duplicated_suffixes <- unique(suffixes[duplicated(suffixes)])

  if (length(duplicated_suffixes) > 0) {
    conflicts <- character(length(duplicated_suffixes))

    for (i in seq_along(duplicated_suffixes)) {
      conflicts[[i]] <- paste(labels[suffixes == duplicated_suffixes[[i]]], collapse = ", ")
    }

    stop(
      "Some ",
      label_type,
      " would create the same generated column-name suffix because dyadMLM replaces spaces and punctuation with underscores: ",
      paste(conflicts, collapse = "; "),
      ". Rename these ",
      rename_hint,
      " so their generated names are unique.",
      call. = FALSE
    )
  }

  stats::setNames(suffixes, labels)
}


#' Resolve user-supplied composition references
#'
#' @param references A character vector of composition references.
#' @param observed_compositions Canonical composition labels observed in the
#'   data.
#' @param arg_name Name of the user-facing argument for error messages.
#'
#' @return Canonical observed composition labels.
#' @keywords internal
resolve_composition_references <- function(references, observed_compositions, arg_name) {
  if (is.null(references)) {
    return(character())
  }

  observed_compositions <- unique(as.character(observed_compositions))
  if (!is.character(references)) {
    stop(
      "`",
      arg_name,
      "` must be a character vector with one string per dyad composition, ",
      "for example `\"female-male\"` or `c(\"female-female\", \"male-male\")`.",
      call. = FALSE
    )
  }
  if (any(is.na(references)) || any(trimws(references) == "")) {
    stop(
      "`",
      arg_name,
      "` must contain non-empty dyad composition references.",
      call. = FALSE
    )
  }

  # initiate empty character vector of same length as references
  reference_values <- character(length(references))
  # try to split correctly!
  for (i in seq_along(references)) {
    reference <- trimws(references[[i]])

    if (grepl(dyad_composition_sep, reference, fixed = TRUE)) {
      roles <- strsplit(reference, dyad_composition_sep, fixed = TRUE)[[1]]
    } else if (grepl("-", reference, fixed = TRUE)) {
      roles <- strsplit(reference, "-", fixed = TRUE)[[1]]
    } else if (grepl("_", reference, fixed = TRUE)) {
      roles <- strsplit(reference, "_", fixed = TRUE)[[1]]
    } else if (grepl("[[:space:]]", reference)) {
      roles <- strsplit(reference, "[[:space:]]+")[[1]]
    } else {
      roles <- reference
    }

    # build cannonical string
    reference_values[[i]] <- canonical_composition(trimws(roles))
  }

  reference_values <- unique(reference_values)

  if (length(reference_values) == 0) {
    return(character())
  }

  unknown_references <- setdiff(reference_values, observed_compositions)
  if (length(unknown_references) > 0) {
    stop(
      "`", arg_name, "` contains unknown dyad composition(s): ",
      paste(unknown_references, collapse = ", "),
      ". Use observed compositions: ",
      paste(observed_compositions, collapse = ", "),
      ".",
      call. = FALSE
    )
  }

  reference_values
}


#' Format group identifiers for validation messages
#'
#' Converts a vector of dyad or group identifiers into a compact comma-separated
#' string for use in validation errors and warnings.
#'
#' @param groups A vector of group identifiers.
#' @param max Maximum number of identifiers to show before truncating the list.
#'
#' @return A single character string.
#' @keywords internal
format_group_list <- function(groups, max = 10) {
  groups <- as.character(groups)

  if (length(groups) <= max) {
    return(paste(groups, collapse = ", "))
  }

  paste0(
    paste(groups[seq_len(max)], collapse = ", "),
    ", ... and ",
    length(groups) - max,
    " more"
  )
}


#' Format counted group identifiers for validation messages
#'
#' Converts a vector of dyad or group identifiers into text that includes both
#' the number of groups and a compact list of their identifiers.
#'
#' @param groups A vector of group identifiers.
#' @param singular Singular label for one group.
#' @param plural Plural label for multiple groups.
#' @param max Maximum number of identifiers to show before truncating the list.
#'
#' @return A single character string.
#' @keywords internal
format_group_count <- function(groups, singular = "dyad", plural = "dyads", max = 10) {
  n_groups <- length(groups)
  group_label <- if (n_groups == 1) singular else plural
  id_label <- if (n_groups == 1) "ID" else "IDs"

  paste0(
    n_groups,
    " ",
    group_label,
    ", with ",
    id_label,
    ": ",
    format_group_list(groups, max = max)
  )
}