R/data_prep_generated_columns.R

In dyadMLM: Tools for Dyadic Multilevel Models

#' Collect dyadMLM-generated columns
#'
#' Returns a normalized, one-row-per-column view of the generated columns
#' recorded in a `dyadMLM` attribute. Shared semantics and display text are
#' supplied by `generated_column_spec_lookup()`.
#'
#' @param meta The `dyadMLM` metadata attribute from a `dyadMLM_data` object.
#'
#' @return A tibble with one row per generated column. The `lag` column is `0`
#'   for contemporaneous columns and `1` for lag-1 columns.
#'
#' @keywords internal
dyad_generated_columns <- function(meta) {
  columns <- meta$generated_columns
  if (is.null(columns) || nrow(columns) == 0L) {
    return(empty_generated_columns())
  }

  columns <- attach_generated_column_specs(columns)
  # This metadata field records the naming style actually used after
  # composition filtering, not merely the value requested by the user.
  if (isTRUE(meta$short_colnames)) {
    columns$column_pattern <- columns$short_column_pattern
    is_exchangeable_indicator <-
      columns$model_family == "composition" &
      columns$column_role == "composition_indicator" &
      columns$column == paste0(dyad_retained_prefix, "is_exchangeable")
    columns$column_pattern[is_exchangeable_indicator] <-
      columns$column[is_exchangeable_indicator]
  }
  columns
}

# Validate a complete stage-level table of proposed generated columns before
# any of them are written. `column_plan` has one row per proposed column:
# `target` is its name, and the remaining fields describe what it represents.
# `data` may already contain columns written by earlier generation stages.
validate_generated_column_plan <- function(data, column_plan) {
  if (nrow(column_plan) == 0L) {
    return(invisible(column_plan))
  }

  # Generated names must be syntactic R names. In particular, a leading dot
  # followed by a number would otherwise require backticks in every formula.
  invalid_name_indices <- which(
    is.na(column_plan$target) |
      make.names(column_plan$target) != column_plan$target
  )
  if (length(invalid_name_indices) > 0L) {
    invalid_name <- column_plan$target[[invalid_name_indices[[1L]]]]
    stop(
      "Generated column name `",
      invalid_name,
      "` is not syntactically valid in R. Rename the associated predictor ",
      "or role so generated columns can be used directly in model formulas.",
      call. = FALSE
    )
  }

  # Turn one row of the plan into the human-readable part of an error message.
  describe_column_origin <- function(column_origin) {
    predictor <- column_origin$predictor[[1L]]
    if (is.na(predictor) || !nzchar(predictor)) {
      predictor <- "<not applicable>"
    }
    paste0(
      "predictor `", predictor,
      "`, temporal component `", column_origin$temporal_component[[1L]],
      "`, lag ", column_origin$lag[[1L]],
      ", model family `", column_origin$model_family[[1L]],
      "`, column role `", column_origin$column_role[[1L]], "`"
    )
  }

  # First check whether two proposed columns have the same name. This can
  # happen when different predictors lead to the same generated suffix.
  duplicate_planned_names <- unique(
    column_plan$target[duplicated(column_plan$target)]
  )
  if (length(duplicate_planned_names) > 0L) {
    collision_name <- duplicate_planned_names[[1L]]
    collision_origins <- column_plan |>
      dplyr::filter(.data$target == collision_name)
    proposed_origin <- collision_origins[1L, , drop = FALSE]
    conflicting_origin <- collision_origins[2L, , drop = FALSE]
  } else {
    # Otherwise check whether a proposed name was generated by an earlier
    # stage. We only need to inspect names that occur in both places.
    planned_names_already_in_data <- intersect(column_plan$target, names(data))
    if (length(planned_names_already_in_data) == 0L) {
      return(invisible(column_plan))
    }

    collision_name <- planned_names_already_in_data[[1L]]
    proposed_origin <- column_plan |>
      dplyr::filter(.data$target == collision_name) |>
      dplyr::slice(1L)

    # Metadata records the meaning of columns generated by earlier stages. Its
    # field names differ from those in `column_plan`.
    existing_generated_column_metadata <- dyad_generated_columns(
      attr(data, "dyadMLM")
    ) |>
      dplyr::filter(.data$column == collision_name) |>
      dplyr::slice(1L)

    if (nrow(existing_generated_column_metadata) > 0L) {
      conflicting_origin <- tibble::tibble(
        target = collision_name,
        predictor = existing_generated_column_metadata$variable,
        temporal_component = existing_generated_column_metadata$component,
        lag = existing_generated_column_metadata$lag,
        model_family = existing_generated_column_metadata$model_family,
        column_role = existing_generated_column_metadata$column_role
      )
    } else {
      # A name absent from the registry belongs to the input data, not to an
      # earlier generation stage.
      conflicting_origin <- tibble::tibble(
        target = collision_name,
        predictor = NA_character_,
        temporal_component = "none",
        lag = 0L,
        model_family = "input",
        column_role = "original"
      )
    }
  }

  # Report the first collision. No columns from this stage have been written,
  # so the caller can safely correct the names and try again.
  stop(
    "Generated-column collision for `", collision_name, "`: ",
    describe_column_origin(proposed_origin),
    " conflicts with ",
    describe_column_origin(conflicting_origin),
    ". Rename or remove the conflicting input column or predictor; dyadMLM ",
    "will not overwrite or number generated columns.",
    call. = FALSE
  )
}

# Typed empty form returned when no generated columns were recorded.
empty_generated_columns <- function() {
  tibble::tibble(
    model_family = character(),
    variable_role = character(),
    variable = character(),
    component = character(),
    lag = integer(),
    column_role = character(),
    column = character(),
    source_column = character(),
    temporal_decomposition = character(),
    dyadic_decomposition = character(),
    column_centering = character(),
    print_order = integer(),
    column_pattern = character(),
    short_column_pattern = character(),
    description = character()
  )
}

# Store the same rows that were used to validate a generation stage. Only
# input-dependent values are stored; shared semantics remain in the lookup.
record_generated_columns <- function(data, column_plan) {
  if (is.null(column_plan) || nrow(column_plan) == 0L) {
    return(data)
  }

  required_fields <- c(
    "target", "predictor", "temporal_component", "lag",
    "model_family", "column_role", "variable_role", "source_column"
  )
  missing_fields <- setdiff(required_fields, names(column_plan))
  if (length(missing_fields) > 0L) {
    stop(
      "Internal error: generated-column plan is missing field(s): ",
      paste(missing_fields, collapse = ", "),
      ". Please report this as a dyadMLM bug with a reproducible example and your package version.",
      call. = FALSE
    )
  }

  columns <- tibble::tibble(
    model_family = column_plan$model_family,
    variable_role = column_plan$variable_role,
    variable = column_plan$predictor,
    component = column_plan$temporal_component,
    lag = column_plan$lag,
    column_role = column_plan$column_role,
    column = column_plan$target,
    source_column = column_plan$source_column
  )

  missing_columns <- setdiff(columns$column, names(data))
  if (length(missing_columns) > 0L) {
    stop(
      "Internal error: generated-column metadata was recorded before column(s) ",
      paste(missing_columns, collapse = ", "),
      " were created. Please report this as a dyadMLM bug with a reproducible example and your package version.",
      call. = FALSE
    )
  }

  # Fail at the generation boundary if a plan has no matching specification.
  invisible(attach_generated_column_specs(columns))

  meta <- attr(data, "dyadMLM")
  recorded_columns <- dplyr::bind_rows(meta$generated_columns, columns)
  duplicated_columns <- unique(
    recorded_columns$column[duplicated(recorded_columns$column)]
  )
  if (length(duplicated_columns) > 0L) {
    stop(
      "Internal error: generated column(s) were recorded more than once: ",
      paste(duplicated_columns, collapse = ", "),
      ". Please report this as a dyadMLM bug with a reproducible example and your package version.",
      call. = FALSE
    )
  }

  meta$generated_columns <- recorded_columns
  attr(data, "dyadMLM") <- meta
  data
}

attach_generated_column_specs <- function(columns) {
  out <- columns |>
    dplyr::left_join(
      generated_column_spec_lookup(),
      by = c("model_family", "variable_role", "component", "column_role")
    )

  spec_cols <- c(
    "temporal_decomposition",
    "dyadic_decomposition",
    "column_centering",
    "print_order",
    "column_pattern",
    "short_column_pattern",
    "description"
  )
  missing_spec <- !stats::complete.cases(out[spec_cols])
  if (any(missing_spec)) {
    missing_keys <- out[missing_spec, c("model_family", "variable_role", "component", "column_role")]
    stop(
      "Internal error: no generated-column specification exists for metadata key(s) ",
      "`model_family`/`variable_role`/`component`/`column_role`: ",
      paste(
        apply(missing_keys, 1, paste, collapse = "/"),
        collapse = ", "
      ),
      ". Please report this as a dyadMLM bug with a reproducible example and your package version.",
      call. = FALSE
    )
  }

  is_lagged <- out$lag > 0L
  out$column_pattern[is_lagged] <- paste0(
    out$column_pattern[is_lagged],
    "_lag",
    out$lag[is_lagged]
  )
  out$short_column_pattern[is_lagged] <- paste0(
    out$short_column_pattern[is_lagged],
    "_lag",
    out$lag[is_lagged]
  )
  out$description[is_lagged] <- paste0(
    "lag-",
    out$lag[is_lagged],
    " ",
    out$description[is_lagged]
  )

  out
}

generated_column_spec_lookup <- function() {
  # Complete patterns keep the naming contract readable in one place. Only
  # composition-dependent columns have a distinct short form.
  column_specs <- tibble::tribble(
    ~model_family,    ~variable_role, ~component, ~column_role,              ~temporal_decomposition,      ~dyadic_decomposition,      ~column_centering, ~print_order, ~column_pattern,                         ~short_column_pattern,                                      ~description,
    "composition",    "composition",  "none",     "composition",             "none",                       "none",                     "none",            1L,           ".composition",                              NA_character_,                                               "inferred dyad composition",
    "composition",    "composition_role", "none", "composition_role",        "none",                       "none",                     "none",            2L,           ".composition_role",                         NA_character_,                                               "composition-specific member role",
    "composition",    "composition_role", "none", "composition_indicator",   "none",                       "none",                     "none",            3L,           ".is_{comp-role}",                           ".is_{role}",                                                 "composition-role indicator columns",
    "composition",    "composition",  "none",     "member_contrast",         "none",                       "none",                     "none",            4L,           ".member_contrast_{comp}_arbitrary",         ".member_contrast_arbitrary",                                 "composition-specific member contrasts coded -1/+1 in arbitrary direction for exchangeability-constrained random effects. Values are 0 for other compositions",
    "temporal",       "predictor",    "raw",      "temporal_component",      "none",                       "none",                     "none",            7L,           ".{pred}",                                   NA_character_,                                               "raw predictor values",
    "temporal",       "predictor",    "cwp",      "temporal_component",      "within_person",              "none",                     "none",            8L,           ".{pred}_cwp",                               NA_character_,                                               "within-person predictor: momentary deviations from each person's usual level",
    "temporal",       "predictor",    "cbp",      "temporal_component",      "between_person_grand_mean",  "none",                     "none",            9L,           ".{pred}_cbp",                               NA_character_,                                               "between-person predictor: stable differences from the average person's usual level",
    "apim",           "predictor",    "gmc",      "source",                 "none",                       "none",                     "grand_mean",      16L,          ".{pred}_gmc",                               NA_character_,                                               "APIM grand-mean-centered predictor source: original values minus the mean across all retained non-missing observations",
    "apim",           "predictor",    "raw",      "actor",                  "none",                       "none",                     "none",            10L,          ".{pred}_actor",                             NA_character_,                                               "APIM actor predictor: actor's original predictor values",
    "apim",           "predictor",    "raw",      "partner",                "none",                       "none",                     "none",            11L,          ".{pred}_partner",                           NA_character_,                                               "APIM partner predictor: partner's original predictor values",
    "apim",           "predictor",    "cwp",      "actor",                  "within_person",              "none",                     "none",            12L,          ".{pred}_cwp_actor",                         NA_character_,                                               "APIM within-person actor predictor: actor's momentary deviations from their usual level",
    "apim",           "predictor",    "cwp",      "partner",                "within_person",              "none",                     "none",            13L,          ".{pred}_cwp_partner",                       NA_character_,                                               "APIM within-person partner predictor: partner's momentary deviations from their usual level",
    "apim",           "predictor",    "cbp",      "actor",                  "between_person_grand_mean",  "none",                     "none",            14L,          ".{pred}_cbp_actor",                         NA_character_,                                               "APIM between-person actor predictor: actor's stable difference from the average person's usual level",
    "apim",           "predictor",    "cbp",      "partner",                "between_person_grand_mean",  "none",                     "none",            15L,          ".{pred}_cbp_partner",                       NA_character_,                                               "APIM between-person partner predictor: partner's stable difference from the average person's usual level",
    "apim",           "predictor",    "gmc",      "actor",                  "none",                       "none",                     "grand_mean",      17L,          ".{pred}_gmc_actor",                         NA_character_,                                               "APIM grand-mean-centered actor predictor: actor's value relative to the mean across all retained non-missing observations",
    "apim",           "predictor",    "gmc",      "partner",                "none",                       "none",                     "grand_mean",      18L,          ".{pred}_gmc_partner",                       NA_character_,                                               "APIM grand-mean-centered partner predictor: partner's value relative to the mean across all retained non-missing observations",
    "dsm",            "role",         "raw",      "role_contrast",          "none",                       "role_contrast",            "none",            19L,          ".dsm_role_contrast",                        NA_character_,                                               "DSM role contrast: +0.5 for the first declared role and -0.5 for the second declared role",
    "dim",            "predictor",    "raw",      "dyad_mean",              "none",                       "dyad_mean",                "grand_mean",      20L,          ".{pred}_dyad_mean_gmc",                     NA_character_,                                               "dyad-mean predictor: dyad's average predictor level, grand-mean centered",
    "dim",            "predictor",    "raw",      "within_dyad_deviation",  "none",                       "within_dyad_deviation",    "none",            21L,          ".{pred}_within_dyad_dev",                   NA_character_,                                               "DIM within-dyad member-deviation predictor: member's difference from the dyad mean",
    "dim",            "predictor",    "cwp",      "dyad_mean",              "within_person",              "dyad_mean",                "none",            22L,          ".{pred}_cwp_dyad_mean",                     NA_character_,                                               "within-person dyad-mean predictor: shared momentary deviations in the dyad",
    "dim",            "predictor",    "cwp",      "within_dyad_deviation",  "within_person",              "within_dyad_deviation",    "none",            23L,          ".{pred}_cwp_within_dyad_dev",               NA_character_,                                               "DIM within-person, within-dyad member-deviation predictor: member's momentary deviation from the dyad mean",
    "dim",            "predictor",    "cbp",      "dyad_mean",              "between_person_grand_mean",  "dyad_mean",                "none",            24L,          ".{pred}_cbp_dyad_mean",                     NA_character_,                                               "between-person dyad-mean predictor: dyad's stable usual level, grand-mean centered",
    "dim",            "predictor",    "cbp",      "within_dyad_deviation",  "between_person_grand_mean",  "within_dyad_deviation",    "none",            25L,          ".{pred}_cbp_within_dyad_dev",               NA_character_,                                               "DIM between-person, within-dyad member-deviation predictor: member's stable difference from the dyad's usual level",
    "dsm",            "predictor",    "raw",      "dyad_mean",              "none",                       "dyad_mean",                "grand_mean",      20L,          ".{pred}_dyad_mean_gmc",                     NA_character_,                                               "dyad-mean predictor: dyad's average predictor level, grand-mean centered",
    "dsm",            "predictor",    "raw",      "dyad_difference",        "none",                       "dyad_difference",          "none",            21L,          ".{pred}_within_dyad_diff",                  NA_character_,                                               "DSM signed predictor difference: first declared role minus second declared role",
    "dsm",            "predictor",    "cwp",      "dyad_mean",              "within_person",              "dyad_mean",                "none",            22L,          ".{pred}_cwp_dyad_mean",                     NA_character_,                                               "within-person dyad-mean predictor: shared momentary deviations in the dyad",
    "dsm",            "predictor",    "cwp",      "dyad_difference",        "within_person",              "dyad_difference",          "none",            23L,          ".{pred}_cwp_within_dyad_diff",              NA_character_,                                               "DSM within-person signed predictor difference: first declared role minus second declared role",
    "dsm",            "predictor",    "cbp",      "dyad_mean",              "between_person_grand_mean",  "dyad_mean",                "none",            24L,          ".{pred}_cbp_dyad_mean",                     NA_character_,                                               "between-person dyad-mean predictor: dyad's stable usual level, grand-mean centered",
    "dsm",            "predictor",    "cbp",      "dyad_difference",        "between_person_grand_mean",  "dyad_difference",          "none",            25L,          ".{pred}_cbp_within_dyad_diff",              NA_character_,                                               "DSM between-person signed predictor difference: first declared role minus second declared role"
  )

  # `NA` marks rows whose short pattern is identical to the regular pattern.
  column_specs$short_column_pattern <- dplyr::coalesce(
    column_specs$short_column_pattern,
    column_specs$column_pattern
  )

  column_specs
}