diff --git a/.Rbuildignore b/.Rbuildignore index 908e2c71..0444b181 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,3 +17,6 @@ ^codecov\.yml$ ^cran-comments\.md$ ^CRAN-SUBMISSION$ +^tmp$ +^Rplots\.pdf$ +^dyadMLM_.*\.tar\.gz$ diff --git a/.github/scripts/export-workshop-slides.sh b/.github/scripts/export-workshop-slides.sh new file mode 100644 index 00000000..749c42b0 --- /dev/null +++ b/.github/scripts/export-workshop-slides.sh @@ -0,0 +1,59 @@ +#!/usr/bin/env bash + +set -euo pipefail + +repository_root="$(cd "${1:-.}" && pwd)" +workshop_output="${repository_root}/docs/workshop" +decktape_image="ghcr.io/astefanutti/decktape:3.16.1@sha256:66f5eff34a444628f5ab524da5390a454412fa879f3d15df96daf4c5c8da6b33" +temporary_root="$(mktemp -d /tmp/dyadmlm-decktape.XXXXXX)" +temporary_input="${temporary_root}/input" +temporary_output="${temporary_root}/output" + +cleanup() { + rm -rf -- "${temporary_root}" +} +trap cleanup EXIT + +mkdir -p "${temporary_input}" "${temporary_output}" "${workshop_output}" + +# DeckTape runs as a non-root user whose UID may differ from the host runner. +# This directory is temporary and contains only the generated PDFs. +chmod 0777 "${temporary_output}" + +# Give the container only the publication-bound slide files. +cp "${repository_root}/dev/workshop/dyad-day.html" \ + "${temporary_input}/dyad-day.html" +cp "${repository_root}/dev/workshop/applied-tutorial.html" \ + "${temporary_input}/applied-tutorial.html" + +# Fragments are intentionally disabled (DeckTape's default), yielding one PDF +# page per Reveal slide with ordinary fragments fully revealed. +docker run --rm \ + --volume "${temporary_input}:/slides:ro,Z" \ + --volume "${temporary_output}:/output:Z" \ + "${decktape_image}" reveal \ + --size 1050x700 \ + --pause 1500 \ + --load-pause 2000 \ + --chrome-arg=--allow-file-access-from-files \ + "file:///slides/dyad-day.html" \ + "/output/01_conceptual_foundations.pdf" + +docker run --rm \ + --volume "${temporary_input}:/slides:ro,Z" \ + --volume "${temporary_output}:/output:Z" \ + "${decktape_image}" reveal \ + --size 1050x700 \ + --pause 1500 \ + --load-pause 2000 \ + --chrome-arg=--allow-file-access-from-files \ + "file:///slides/applied-tutorial.html" \ + "/output/02_applied_tutorial.pdf" + +test -s "${temporary_output}/01_conceptual_foundations.pdf" +test -s "${temporary_output}/02_applied_tutorial.pdf" + +install -m 0644 "${temporary_output}/01_conceptual_foundations.pdf" \ + "${workshop_output}/01_conceptual_foundations.pdf" +install -m 0644 "${temporary_output}/02_applied_tutorial.pdf" \ + "${workshop_output}/02_applied_tutorial.pdf" diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 37481ed6..f462ee47 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -4,8 +4,6 @@ on: push: branches: [main, master] pull_request: - release: - types: [published] workflow_dispatch: name: pkgdown @@ -24,6 +22,45 @@ jobs: contents: write steps: - uses: actions/checkout@v7 + with: + fetch-depth: 0 + + - name: Determine whether workshop materials changed + id: workshop-changes + shell: bash + env: + EVENT_NAME: ${{ github.event_name }} + BEFORE_SHA: ${{ github.event.before }} + BASE_SHA: ${{ github.event.pull_request.base.sha }} + PR_HEAD_SHA: ${{ github.event.pull_request.head.sha }} + HEAD_SHA: ${{ github.sha }} + run: | + rebuild=true + # Paths that directly define the published workshop outputs. + workshop_paths=( + dev/workshop + vignettes/diagram-helpers.Rinc + vignettes/dim-grid.Rinc + vignettes/references.bib + pkgdown/templates/content-workshop.html + _pkgdown.yml + .github/scripts/export-workshop-slides.sh + .github/workflows/pkgdown.yaml + ) + + if [[ "$EVENT_NAME" == "push" && ! "$BEFORE_SHA" =~ ^0+$ ]]; then + if git diff --quiet "$BEFORE_SHA" "$HEAD_SHA" -- \ + "${workshop_paths[@]}"; then + rebuild=false + fi + elif [[ "$EVENT_NAME" == "pull_request" ]]; then + if git diff --quiet "$BASE_SHA...$PR_HEAD_SHA" -- \ + "${workshop_paths[@]}"; then + rebuild=false + fi + fi + + echo "rebuild=$rebuild" >> "$GITHUB_OUTPUT" - uses: r-lib/actions/setup-pandoc@v2 @@ -31,19 +68,91 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: any::pkgdown, local::. + extra-packages: | + any::DHARMa + any::digest + any::ggplot2 + any::gridExtra + any::modelbased + any::parameters + any::patchwork + any::pkgdown + any::report + any::RSA + any::see + any::tidyr + any::wbCorr + local::. needs: website + - uses: quarto-dev/quarto-actions/setup@v2 + + - name: Render all workshop materials + if: steps.workshop-changes.outputs.rebuild == 'true' + run: | + quarto render dev/workshop/dyad-day.qmd + quarto render dev/workshop/applied-tutorial.qmd + - name: Build site run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) shell: Rscript {0} + - name: Export workshop slides to PDF + if: steps.workshop-changes.outputs.rebuild == 'true' + run: bash .github/scripts/export-workshop-slides.sh + - name: Add workshop materials + if: steps.workshop-changes.outputs.rebuild == 'true' run: | mkdir -p docs/workshop/conceptual docs/workshop/applied Rscript -e 'pkgdown::render_page(".", "workshop", data = list(pagetitle = "Workshop", description = "Dyadic Data Analysis workshop materials."), path = "workshop/index.html", depth = 1)' cp dev/workshop/dyad-day.html docs/workshop/conceptual/index.html cp dev/workshop/applied-tutorial.html docs/workshop/applied/index.html + cp dev/workshop/03_exercises_cross_sectional.Rmd docs/workshop/03_exercises_cross_sectional.Rmd + cp dev/workshop/04_exercises_ild.Rmd docs/workshop/04_exercises_ild.Rmd + zip -jq docs/workshop/dyadic-data-analysis-workshop.zip \ + dev/workshop/00_setup.R \ + docs/workshop/01_conceptual_foundations.pdf \ + docs/workshop/02_applied_tutorial.pdf \ + dev/workshop/03_exercises_cross_sectional.Rmd \ + dev/workshop/04_exercises_ild.Rmd \ + dev/workshop/dyadic-data.rds \ + dev/workshop/dyadic-ild-exercise.rds \ + dev/workshop/dyadic-person-means.rds \ + dev/workshop/helpers.R \ + dev/workshop/hints.R + + - name: Preserve previously published workshop materials + if: >- + steps.workshop-changes.outputs.rebuild != 'true' && + github.event_name != 'pull_request' + run: | + git fetch --no-tags --depth=1 origin gh-pages + git archive --format=tar \ + --output=/tmp/dyadmlm-published-workshop.tar \ + FETCH_HEAD workshop + tar -xf /tmp/dyadmlm-published-workshop.tar -C docs + + - name: Validate staged workshop materials + if: github.event_name != 'pull_request' || steps.workshop-changes.outputs.rebuild == 'true' + shell: bash + run: | + workshop_files=( + docs/workshop/index.html + docs/workshop/conceptual/index.html + docs/workshop/applied/index.html + docs/workshop/01_conceptual_foundations.pdf + docs/workshop/02_applied_tutorial.pdf + docs/workshop/03_exercises_cross_sectional.Rmd + docs/workshop/04_exercises_ild.Rmd + docs/workshop/dyadic-data-analysis-workshop.zip + ) + + for workshop_file in "${workshop_files[@]}"; do + test -s "$workshop_file" + done + + unzip -tq docs/workshop/dyadic-data-analysis-workshop.zip - name: Deploy to GitHub pages 🚀 if: github.event_name != 'pull_request' diff --git a/.gitignore b/.gitignore index 553797ca..b6b79ed0 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,6 @@ HANDOFF.md docs /dyadMLM_*.tar.gz /*.Rcheck/ +/Rplots.pdf +/dev/workshop/temp_audit/ +/dev/workshop/applied-tutorial_cache/ diff --git a/DESCRIPTION b/DESCRIPTION index a129746f..4c4ed12b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: dyadMLM Title: Tools for Dyadic Multilevel Models -Version: 0.1.0 +Version: 0.1.0.9000 Authors@R: person("Pascal", "Küng", , "kueng.pascal@gmail.com", role = c("aut", "cre", "cph"), diff --git a/NAMESPACE b/NAMESPACE index 6d1cea3b..c428e59a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,7 +3,8 @@ S3method(print,dyadMLM_data) S3method(print,dyadMLM_model_comparison) S3method(print,exchangeable_rescov) -export(compare_nested_glmmTMB_models) +S3method(summary,dyadMLM_data) +export(compare_nested_models) export(prepare_dyad_data) export(recover_exchangeable_covariance) importFrom(rlang,":=") diff --git a/NEWS.md b/NEWS.md index 08f81af5..9771b28e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,35 @@ +# dyadMLM (development version) + +* Retained generated columns now use a single leading dot instead of `.dy_` + for more readable model formulas; for example, `.dy_x_actor` becomes + `.x_actor`. The `.dy_` prefix is reserved for temporary implementation + columns. +* `prepare_dyad_data()` now uses compact composition-column names when the + final data contain one composition, such as `.is_female` and + `.member_contrast_arbitrary`. Set `short_colnames = FALSE` to retain + composition-qualified names. `recover_exchangeable_covariance()` recognizes + both forms. +* `prepare_dyad_data(include_arbitrary_member_contrast = TRUE)` can now add arbitrary + member contrasts for distinguishable compositions without changing their + metadata or role indicators. This supports full and + exchangeability-constrained APIMs from the same prepared data. + `set_exchangeable_compositions` still performs reclassification for pooling + and DIM preparation. +* Added a `summary()` method for prepared data that prints the dyadic structure + followed by standard summaries of all columns. +* Generated-column tracking now records all retained composition and modeling + columns. Printing and model comparison use these records rather than + inferring column ownership from a prefix, and generated names are checked for + collisions and valid R syntax before they are written. +* `prepare_dyad_data(add_apim_gmc_predictors = TRUE)` now adds GMC source, + actor, and partner columns alongside raw APIM columns, plus lagged variants + when requested. It uses one mean over retained non-missing values, warns + about skipped non-numeric predictors in mixed selections, and leaves DIM/DSM + centering unchanged. +* Renamed `compare_nested_glmmTMB_models()` to `compare_nested_models()`. +* Added package-level help at `?dyadMLM`, with links to the main functions, + example datasets, and getting-started documentation. + # dyadMLM 0.1.0 * Initial release. diff --git a/R/add_actor_partner_columns.R b/R/add_actor_partner_columns.R index 877b26d4..7026932c 100644 --- a/R/add_actor_partner_columns.R +++ b/R/add_actor_partner_columns.R @@ -6,8 +6,8 @@ #' predictors, this will create actor and partner versions of the raw predictor #' and each recorded predictor component, such as the within-person and #' between-person components created by [center_predictors()]. -#' Selected lag predictors additionally create lag-1 raw and within-person -#' actor and partner columns. +#' Selected lag predictors also create actor and partner columns for eligible +#' lagged components. #' #' The function will use the predictor decomposition metadata stored in #' `attr(data, "dyadMLM")$temporal_decompositions`, so downstream code does @@ -69,7 +69,7 @@ add_actor_partner_columns <- function(data) { } if (component == "raw") { predictor_suffix <- make_dyad_suffixes(predictor)[[predictor]] - column_stem <- paste0(dyad_reserved_prefix, predictor_suffix) + column_stem <- paste0(dyad_retained_prefix, predictor_suffix) } lag_suffix <- make_predictor_lag_suffix(lag) @@ -94,7 +94,9 @@ add_actor_partner_columns <- function(data) { temporal_component = apim_predictors$component, lag = apim_predictors$lag, model_family = "apim", - column_role = "actor" + column_role = "actor", + variable_role = "predictor", + source_column = apim_predictors$source_column ), tibble::tibble( target = apim_predictors$partner_column, @@ -102,7 +104,9 @@ add_actor_partner_columns <- function(data) { temporal_component = apim_predictors$component, lag = apim_predictors$lag, model_family = "apim", - column_role = "partner" + column_role = "partner", + variable_role = "predictor", + source_column = apim_predictors$source_column ) ) validate_generated_column_plan(out, apim_plan) @@ -172,6 +176,7 @@ add_actor_partner_columns <- function(data) { } attr(out, "dyadMLM")$apim_predictors <- apim_predictors + out <- record_generated_columns(out, apim_plan) return(out) } diff --git a/R/add_dyad_individual_columns.R b/R/add_dyad_individual_columns.R index 92069e93..40c8116e 100644 --- a/R/add_dyad_individual_columns.R +++ b/R/add_dyad_individual_columns.R @@ -43,6 +43,7 @@ add_dyad_individual_columns <- function(data) { decomposition <- construct_dyad_predictor_decompositions(data, "dim") out <- decomposition$data attr(out, "dyadMLM")$dim_predictors <- decomposition$predictors + out <- record_generated_columns(out, decomposition$column_plan) out } @@ -53,7 +54,10 @@ construct_dyad_predictor_decompositions <- function(data, model_family = "dim") member <- meta_data$member has_time <- meta_data$longitudinal time <- meta_data$time - temporal_decompositions <- meta_data$temporal_decompositions + # Grand-mean-centered source components are generated specifically for APIM. + # DIM and DSM retain their existing raw dyad-mean centering conventions. + temporal_decompositions <- meta_data$temporal_decompositions |> + dplyr::filter(.data$component != "gmc") predictors <- tibble::tibble( predictor = character(), @@ -65,10 +69,6 @@ construct_dyad_predictor_decompositions <- function(data, model_family = "dim") dyad_decomposition_level = character() ) - if (nrow(temporal_decompositions) == 0) { - return(list(data = data, predictors = predictors)) - } - out <- data # First resolve one complete manifest and metadata table. The second loop @@ -116,16 +116,20 @@ construct_dyad_predictor_decompositions <- function(data, model_family = "dim") predictor = predictors$predictor, temporal_component = predictors$component, lag = predictors$lag, - model_family = model_family, - column_role = "dyad_mean" + model_family = rep(model_family, nrow(predictors)), + column_role = rep("dyad_mean", nrow(predictors)), + variable_role = rep("predictor", nrow(predictors)), + source_column = predictors$source_column ), tibble::tibble( target = predictors$deviation_column, predictor = predictors$predictor, temporal_component = predictors$component, lag = predictors$lag, - model_family = model_family, - column_role = "within_dyad_deviation" + model_family = rep(model_family, nrow(predictors)), + column_role = rep("within_dyad_deviation", nrow(predictors)), + variable_role = rep("predictor", nrow(predictors)), + source_column = predictors$source_column ) ) validate_generated_column_plan(out, decomposition_plan) @@ -160,7 +164,11 @@ construct_dyad_predictor_decompositions <- function(data, model_family = "dim") } } - list(data = out, predictors = predictors) + list( + data = out, + predictors = predictors, + column_plan = decomposition_plan + ) } make_dyad_predictor_column_stem <- function(predictor, component, source_col, @@ -174,7 +182,7 @@ make_dyad_predictor_column_stem <- function(predictor, component, source_col, } predictor_suffix <- make_dyad_suffixes(predictor)[[predictor]] - paste0(dyad_reserved_prefix, predictor_suffix) + paste0(dyad_retained_prefix, predictor_suffix) } add_dyad_time_decomposition <- function(out, group, member, time, source_col, diff --git a/R/add_dyadic_score_columns.R b/R/add_dyadic_score_columns.R index 66885a62..826aa1c1 100644 --- a/R/add_dyadic_score_columns.R +++ b/R/add_dyadic_score_columns.R @@ -38,6 +38,18 @@ add_dyadic_score_columns <- function(data) { dsm_role_order <- meta_data$dsm_role_order role <- meta_data$role + role_contrast_plan <- tibble::tibble( + target = dyad_dsm_role_contrast_col, + predictor = role, + temporal_component = "raw", + lag = 0L, + model_family = "dsm", + column_role = "role_contrast", + variable_role = "role", + source_column = role + ) + validate_generated_column_plan(data, role_contrast_plan) + data[[dyad_dsm_role_contrast_col]] <- ifelse( as.character(data[[role]]) == dsm_role_order[[1]], 0.5, @@ -78,7 +90,9 @@ add_dyadic_score_columns <- function(data) { temporal_component = decomposition$predictors$component, lag = decomposition$predictors$lag, model_family = rep("dsm", n_predictors), - column_role = rep("dyad_difference", n_predictors) + column_role = rep("dyad_difference", n_predictors), + variable_role = rep("predictor", n_predictors), + source_column = decomposition$predictors$source_column ) validate_generated_column_plan(out, difference_plan) @@ -108,6 +122,15 @@ add_dyadic_score_columns <- function(data) { attr(out, "dyadMLM")$dsm_predictors <- dsm_predictors attr(out, "dyadMLM")$dsm_role_contrast_column <- dyad_dsm_role_contrast_col + generated_column_plan <- dplyr::bind_rows( + role_contrast_plan, + dplyr::filter( + decomposition$column_plan, + .data$column_role == "dyad_mean" + ), + difference_plan + ) + out <- record_generated_columns(out, generated_column_plan) out } diff --git a/R/add_temporal_lag_columns.R b/R/add_temporal_lag_columns.R index 20b7c39d..4dec53df 100644 --- a/R/add_temporal_lag_columns.R +++ b/R/add_temporal_lag_columns.R @@ -1,9 +1,8 @@ #' Add lagged temporal predictor columns #' -#' Adds lag-1 raw and within-person columns for predictors selected through -#' `lag1_predictors`. Values are matched at exactly `time - 1`, so construction -#' does not depend on row order and does not bridge gaps in the measurement -#' index. Stable between-person components are not lagged. +#' Adds eligible lag-1 raw, within-person, and APIM GMC source columns. +#' Values are matched at exactly `time - 1`; gaps are not bridged. Stable +#' between-person components are not lagged. #' #' @param data A `dyadMLM_data` object returned by [prepare_dyad_data()]. #' @@ -33,7 +32,7 @@ add_temporal_lag_columns <- function(data) { lag_sources <- decompositions |> dplyr::filter( .data$predictor %in% lag1_predictors, - .data$component %in% c("raw", "cwp"), + .data$component %in% c("raw", "cwp", "gmc"), .data$lag == 0L ) @@ -45,7 +44,7 @@ add_temporal_lag_columns <- function(data) { lag_col <- paste0(source_col, "_lag1") if (component == "raw") { predictor_suffix <- make_dyad_suffixes(predictor)[[predictor]] - lag_col <- paste0(dyad_reserved_prefix, predictor_suffix, "_lag1") + lag_col <- paste0(dyad_retained_prefix, predictor_suffix, "_lag1") } lag_columns[[i]] <- lag_col } @@ -54,8 +53,18 @@ add_temporal_lag_columns <- function(data) { predictor = lag_sources$predictor, temporal_component = lag_sources$component, lag = 1L, - model_family = "temporal", - column_role = "temporal_component" + model_family = ifelse( + lag_sources$component == "gmc", + "apim", + "temporal" + ), + column_role = ifelse( + lag_sources$component == "gmc", + "source", + "temporal_component" + ), + variable_role = "predictor", + source_column = lag_sources$column ) validate_generated_column_plan(data, lag_plan) @@ -104,6 +113,7 @@ add_temporal_lag_columns <- function(data) { meta_data$temporal_decompositions <- decompositions attr(out, "dyadMLM") <- meta_data class(out) <- class(data) + out <- record_generated_columns(out, lag_plan) out } diff --git a/R/backtransform_residual_covariance.R b/R/backtransform_residual_covariance.R index ff9e388f..33ecefee 100644 --- a/R/backtransform_residual_covariance.R +++ b/R/backtransform_residual_covariance.R @@ -31,9 +31,9 @@ #' an ordinary intercept is the shared intercept coordinate. #' #' @details -#' Automatic matching recognizes exact `.dy_member_contrast_*_arbitrary` and -#' legacy `.dy_diff_*_arbitrary` coefficient names -#' and first looks for the corresponding `.dy_is_*` shared block. It requires +#' Automatic matching recognizes the compact `.member_contrast_arbitrary` and +#' composition-qualified `.member_contrast_*_arbitrary` names. It first looks +#' for the corresponding `.is_*` shared block. It requires #' the two blocks to use the same grouping factor and the same underlying #' terms. Most models fitted with `dyadMLM`-generated columns therefore need #' only: @@ -69,15 +69,15 @@ #' block_pairings = list( #' dyad = list( #' shared_block = "(1 + diaryday | coupleID)", -#' difference_block = "(0 + .dy_member_contrast_assumed_exchangeable_arbitrary | coupleID)", +#' difference_block = "(0 + .member_contrast_arbitrary | coupleID)", #' difference_indicator = -#' ".dy_member_contrast_assumed_exchangeable_arbitrary" +#' ".member_contrast_arbitrary" #' ), #' same_occasion = list( #' shared_block = "(1 | coupleID:diaryday)", -#' difference_block = "(0 + .dy_member_contrast_assumed_exchangeable_arbitrary | coupleID:diaryday)", +#' difference_block = "(0 + .member_contrast_arbitrary | coupleID:diaryday)", #' difference_indicator = -#' ".dy_member_contrast_assumed_exchangeable_arbitrary" +#' ".member_contrast_arbitrary" #' ) #' ) #' ) @@ -192,7 +192,7 @@ #' model <- glmmTMB::glmmTMB( #' closeness ~ 1 + #' us(1 | coupleID) + -#' us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID), +#' us(0 + .member_contrast_arbitrary | coupleID), #' dispformula = ~ 0, #' data = example_data #' ) @@ -620,6 +620,35 @@ exchangeable_underlying_terms <- function(coefficients, indicator = "1") { return(terms) } +is_generated_exchangeable_difference_indicator <- function(column_names) { + column_specs <- generated_column_spec_lookup() + # Derive both supported forms from the shared specification so automatic + # matching stays aligned with generated-column naming. + short_member_contrast_name <- column_specs$short_column_pattern[ + column_specs$model_family == "composition" & + column_specs$column_role == "member_contrast" + ] + qualified_member_contrast_pattern <- column_specs$column_pattern[ + column_specs$model_family == "composition" & + column_specs$column_role == "member_contrast" + ] + qualified_member_contrast_prefix <- sub( + "{comp}_arbitrary", + "", + qualified_member_contrast_pattern, + fixed = TRUE + ) + + # The compact name is exact; a qualified name must contain a composition. + column_names %in% short_member_contrast_name | + ( + startsWith(column_names, qualified_member_contrast_prefix) & + endsWith(column_names, "_arbitrary") & + nchar(column_names) > + nchar(paste0(qualified_member_contrast_prefix, "_arbitrary")) + ) +} + find_exchangeable_difference_indicator <- function(coefficients) { variables <- character() for (coefficient in coefficients) { @@ -628,11 +657,9 @@ find_exchangeable_difference_indicator <- function(coefficients) { parse_exchangeable_coefficient(coefficient)$variables ) } - generated_indicators <- unique(grep( - "^\\.dy_(member_contrast|diff)_.+_arbitrary$", - variables, - value = TRUE - )) + generated_indicators <- unique( + variables[is_generated_exchangeable_difference_indicator(variables)] + ) if (length(generated_indicators) > 1L) { stop( @@ -779,7 +806,8 @@ validate_exchangeable_coding <- function( # 6. Generated indicators are stable by construction. For a custom # indicator supplied through `block_pairings`, also check its selected grouping level. - if (grepl("^\\.dy_(member_contrast|diff)_.+_arbitrary$", idiff) || is.null(group_name)) { + if (is_generated_exchangeable_difference_indicator(idiff) || + is.null(group_name)) { return(invisible(NULL)) } if (is.null(group_ids) || @@ -1105,7 +1133,8 @@ match_exchangeable_residual_blocks <- function( ) if (length(difference_indicators) == 0L) { stop( - "No supported `.dy_member_contrast_*_arbitrary` or legacy `.dy_diff_*_arbitrary` difference block was found.", + "No supported `.member_contrast_arbitrary` ", + "or `.member_contrast_*_arbitrary` difference block was found.", " Supply `block_pairings` explicitly if the model uses custom ", "difference-indicator names or unequal shared and difference term sets.", format_exchangeable_block_inventory(blocks), @@ -1113,17 +1142,64 @@ match_exchangeable_residual_blocks <- function( ) } - # 2. Match every discovered composition independently. An ordinary shared - # intercept is a safe fallback only when there is one exchangeable type. + # 2. Match each discovered difference indicator independently. An ordinary + # shared intercept is a safe fallback only when there is one such indicator. matched_pairs <- list() + column_specs <- generated_column_spec_lookup() + # Derive both naming forms from the same specifications used for display. + short_member_contrast_name <- column_specs$short_column_pattern[ + column_specs$model_family == "composition" & + column_specs$column_role == "member_contrast" + ] + short_composition_indicator_pattern <- column_specs$short_column_pattern[ + column_specs$model_family == "composition" & + column_specs$column_role == "composition_indicator" + ] + qualified_member_contrast_pattern <- column_specs$column_pattern[ + column_specs$model_family == "composition" & + column_specs$column_role == "member_contrast" + ] + qualified_member_contrast_prefix <- sub( + "{comp}_arbitrary", + "", + qualified_member_contrast_pattern, + fixed = TRUE + ) + qualified_composition_indicator_pattern <- column_specs$column_pattern[ + column_specs$model_family == "composition" & + column_specs$column_role == "composition_indicator" + ] + for (idiff in difference_indicators) { - composition <- sub("^\\.dy_member_contrast_", "", idiff) - composition <- sub("^\\.dy_diff_", "", composition) - composition <- sub("_arbitrary$", "", composition) + if (identical(idiff, short_member_contrast_name)) { + # A compact member contrast can only represent one exchangeable + # composition, whose compact shared indicator uses "exchangeable". + shared_indicator <- sub( + "{role}", + "exchangeable", + short_composition_indicator_pattern, + fixed = TRUE + ) + } else { + composition_suffix <- sub( + qualified_member_contrast_prefix, + "", + idiff, + fixed = TRUE + ) + composition_suffix <- sub("_arbitrary$", "", composition_suffix) + shared_indicator <- sub( + "{comp-role}", + composition_suffix, + qualified_composition_indicator_pattern, + fixed = TRUE + ) + } + indicator_pairs <- match_blocks_for_exchangeable_indicator( blocks, idiff, - shared_indicator = paste0(".dy_is_", composition), + shared_indicator = shared_indicator, fallback_indicator = if (length(difference_indicators) == 1L) "1" else NULL, model_frame = model_frame ) diff --git a/R/center_predictors.R b/R/center_predictors.R index 6e8849a8..64f88dca 100644 --- a/R/center_predictors.R +++ b/R/center_predictors.R @@ -5,6 +5,7 @@ #' a within-person component and a between-person component. The original #' predictor remains available as a raw component for model-specific column #' construction. +#' It can also add GMC source components for numeric APIM predictors. #' For two-level temporal centering, the between-person component is centered #' around the grand mean of person means, not the grand mean of all observed rows. #' This gives each person equal weight even when people have different numbers of @@ -14,12 +15,13 @@ #' [prepare_dyad_data()]. #' #' @param data A `dyadMLM_data` object returned by [prepare_dyad_data()]. +#' @param add_apim_gmc_predictors Whether to add APIM GMC source components. #' #' @return A `dyadMLM_data` object with centered predictor columns added and #' updated predictor metadata. #' #' @keywords internal -center_predictors <- function(data) { +center_predictors <- function(data, add_apim_gmc_predictors = FALSE) { if (!inherits(data, "dyadMLM_data")) { stop( "`data` must be a `dyadMLM_data` object returned by `prepare_dyad_data()`.", @@ -60,6 +62,55 @@ center_predictors <- function(data) { ) if (temporal_decomposition == "none") { + if (add_apim_gmc_predictors) { + predictor_is_numeric <- logical(length(predictors)) + for (predictor_index in seq_along(predictors)) { + predictor <- predictors[[predictor_index]] + predictor_is_numeric[[predictor_index]] <- is.numeric(out[[predictor]]) + } + + numeric_predictors <- predictors[predictor_is_numeric] + numeric_predictor_suffixes <- make_dyad_suffixes(numeric_predictors) + grand_mean_centered_columns <- paste0( + dyad_retained_prefix, + unname(numeric_predictor_suffixes), + "_gmc" + ) + + # Validate all GMC source names before writing any of them. + grand_mean_centering_plan <- tibble::tibble( + target = grand_mean_centered_columns, + predictor = numeric_predictors, + temporal_component = "gmc", + lag = 0L, + model_family = "apim", + column_role = "source", + variable_role = "predictor", + source_column = numeric_predictors + ) + validate_generated_column_plan(out, grand_mean_centering_plan) + + for (i in seq_along(numeric_predictors)) { + predictor <- numeric_predictors[[i]] + grand_mean_centered_column <- grand_mean_centered_columns[[i]] + predictor_grand_mean <- no_NaN_mean(out[[predictor]]) + + out[[grand_mean_centered_column]] <- + out[[predictor]] - predictor_grand_mean + + temporal_decompositions <- tibble::add_row( + temporal_decompositions, + predictor = predictor, + component = "gmc", + column = grand_mean_centered_column, + temporal_decomposition = "none", + lag = 0L + ) + } + + out <- record_generated_columns(out, grand_mean_centering_plan) + } + attr(out, "dyadMLM")$temporal_decompositions <- temporal_decompositions return(out) @@ -72,8 +123,8 @@ center_predictors <- function(data) { # order and guarantees that this stage fails before writing any columns. plan <- tibble::tibble( target = c( - paste0(dyad_reserved_prefix, unname(predictor_suffixes), "_cwp"), - paste0(dyad_reserved_prefix, unname(predictor_suffixes), "_cbp") + paste0(dyad_retained_prefix, unname(predictor_suffixes), "_cwp"), + paste0(dyad_retained_prefix, unname(predictor_suffixes), "_cbp") ), predictor = rep(predictors, 2L), temporal_component = c( @@ -82,15 +133,17 @@ center_predictors <- function(data) { ), lag = 0L, model_family = "temporal", - column_role = "temporal_component" + column_role = "temporal_component", + variable_role = "predictor", + source_column = rep(predictors, 2L) ) validate_generated_column_plan(out, plan) for (predictor in predictors) { predictor_suffix <- predictor_suffixes[[predictor]] person_mean_col <- paste0(dyad_reserved_prefix, predictor_suffix, "_person_mean") - cwp_col <- paste0(dyad_reserved_prefix, predictor_suffix, "_cwp") - cbp_col <- paste0(dyad_reserved_prefix, predictor_suffix, "_cbp") + cwp_col <- paste0(dyad_retained_prefix, predictor_suffix, "_cwp") + cbp_col <- paste0(dyad_retained_prefix, predictor_suffix, "_cbp") person_means <- out |> dplyr::group_by(.data[[dyad]], .data[[member]]) |> @@ -121,6 +174,7 @@ center_predictors <- function(data) { } attr(out, "dyadMLM")$temporal_decompositions <- temporal_decompositions + out <- record_generated_columns(out, plan) return(out) } diff --git a/R/compare_dyad_models.R b/R/compare_nested_models.R similarity index 95% rename from R/compare_dyad_models.R rename to R/compare_nested_models.R index e25c355d..6ae8f143 100644 --- a/R/compare_dyad_models.R +++ b/R/compare_nested_models.R @@ -12,7 +12,7 @@ #' Both model calls must use named data-frame objects that remain available when #' the models are compared. The checks assume these objects have not been #' modified since fitting. All ordinary data columns must be identical, -#' including their types and attributes. For `dyadMLM_data`, generated `.dy_` +#' including their types and attributes. For `dyadMLM_data`, package-generated #' columns may differ, but the original columns must be identical. Ordinary and #' prepared data may be compared with each other. Dyad metadata are checked when #' both models use `dyadMLM_data`. The function also checks fitted rows, @@ -54,11 +54,11 @@ #' data = full_data #' ) #' -#' compare_nested_glmmTMB_models(restricted_model, full_model) +#' compare_nested_models(restricted_model, full_model) #' } #' #' @export -compare_nested_glmmTMB_models <- function(model1, model2) { +compare_nested_models <- function(model1, model2) { validate_comparison_model(model1, "model1") validate_comparison_model(model2, "model2") @@ -142,7 +142,7 @@ comparison_model_data <- function(model, caller_env, argument) { model_formula <- stats::formula(model, component = "cond") # A model fitted inside a helper may keep its data with its formula. - # Search there first, then where compare_nested_glmmTMB_models() was called. + # Search there first, then where compare_nested_models() was called. environments <- list(environment(model_formula), caller_env) for (search_env in environments) { @@ -200,14 +200,21 @@ validate_comparison_data <- function(model1, model2, } } - # Generated dyadMLM columns may differ across model parameterizations. + # Generated dyadMLM columns may differ across model parameterizations. Use + # their recorded names rather than treating a prefix as column ownership. model1_columns <- names(model1_data) model2_columns <- names(model2_data) if (inherits(model1_data, "dyadMLM_data")) { - model1_columns <- model1_columns[!startsWith(model1_columns, ".dy_")] + generated_columns <- dyad_generated_columns( + attr(model1_data, "dyadMLM") + )$column + model1_columns <- model1_columns[!model1_columns %in% generated_columns] } if (inherits(model2_data, "dyadMLM_data")) { - model2_columns <- model2_columns[!startsWith(model2_columns, ".dy_")] + generated_columns <- dyad_generated_columns( + attr(model2_data, "dyadMLM") + )$column + model2_columns <- model2_columns[!model2_columns %in% generated_columns] } if (!setequal(model1_columns, model2_columns)) { diff --git a/R/data.R b/R/data.R index a9e39947..98f2cd7a 100644 --- a/R/data.R +++ b/R/data.R @@ -34,6 +34,12 @@ #' dyads and exchangeable female-female and male-male dyads. Each dyad has two #' members observed on 14 diary days. #' +#' The Gaussian outcome includes independent member-specific stationary AR(1) +#' residual processes. Their marginal standard deviation is 0.60 for both +#' genders, with correlations of 0.55 for female members and 0.50 for male +#' members. Separate shared and difference residuals induce same-occasion +#' partner covariance. +#' #' Prepare with `dyad = coupleID`, `member = personID`, `role = gender`, and #' `time = diaryday`. These data contain three compositions. Use #' `keep_compositions` in [prepare_dyad_data()] when an analysis should retain diff --git a/R/dyad-generated-columns.R b/R/dyad-generated-columns.R index 65fb5820..7a05d013 100644 --- a/R/dyad-generated-columns.R +++ b/R/dyad-generated-columns.R @@ -1,28 +1,28 @@ #' Collect dyadMLM-generated columns #' -#' Creates a normalized, one-row-per-column view over temporal predictor, APIM, -#' DIM, and DSM columns stored in a `dyadMLM` attribute. This is a -#' derived lookup table; the model-specific metadata tables remain the source -#' records. +#' 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 temporal predictor, APIM, DIM, -#' or DSM column. The `lag` column is `0` for contemporaneous columns and `1` -#' for lag-1 columns. +#' @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) { - dplyr::bind_rows( - temporal_predictor_generated_columns(meta$temporal_decompositions), - apim_generated_columns(meta$apim_predictors), - dim_generated_columns(meta$dim_predictors), - dsm_generated_columns( - dsm_predictors = meta$dsm_predictors, - role_contrast_column = meta$dsm_role_contrast_column, - role_column = meta$role - ) - ) + 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 + } + columns } # Validate a complete stage-level table of proposed generated columns before @@ -34,6 +34,23 @@ validate_generated_column_plan <- function(data, column_plan) { 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]] @@ -73,8 +90,8 @@ validate_generated_column_plan <- function(data, column_plan) { dplyr::filter(.data$target == collision_name) |> dplyr::slice(1L) - # Metadata records the meaning of temporal, APIM, DIM, and DSM columns - # generated earlier. Its field names differ from those in `column_plan`. + # 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") ) |> @@ -91,21 +108,15 @@ validate_generated_column_plan <- function(data, column_plan) { column_role = existing_generated_column_metadata$column_role ) } else { - # Composition columns are created before predictor metadata exists. - # Their name still lets us report which kind of column is in the way. - existing_column_role <- dplyr::case_when( - startsWith(collision_name, ".dy_is_") ~ "composition_indicator", - startsWith(collision_name, ".dy_member_contrast_") | - startsWith(collision_name, ".dy_diff_") ~ "member_contrast", - .default = "previously_generated" - ) + # 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 = "composition", - column_role = existing_column_role + model_family = "input", + column_role = "original" ) } } @@ -117,14 +128,13 @@ validate_generated_column_plan <- function(data, column_plan) { describe_column_origin(proposed_origin), " conflicts with ", describe_column_origin(conflicting_origin), - ". Rename or remove a conflicting predictor; dyadMLM will not overwrite ", - "or number generated columns.", + ". Rename or remove the conflicting input column or predictor; dyadMLM ", + "will not overwrite or number generated columns.", call. = FALSE ) } -# Used as an empty tibble that is identical for each model type and is returned, -# if that model type is not applicable/requested. +# Typed empty form returned when no generated columns were recorded. empty_generated_columns <- function() { tibble::tibble( model_family = character(), @@ -140,153 +150,73 @@ empty_generated_columns <- function() { column_centering = character(), print_order = integer(), column_pattern = character(), + short_column_pattern = character(), description = character() ) } -temporal_predictor_generated_columns <- function(temporal_decompositions) { - if (is.null(temporal_decompositions) || - nrow(temporal_decompositions) == 0) { - return(empty_generated_columns()) +# 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) } - temporal_decompositions <- temporal_decompositions[ - temporal_decompositions$component %in% c("cwp", "cbp") | - temporal_decompositions$lag > 0L, - , - drop = FALSE - ] - - if (nrow(temporal_decompositions) == 0) { - return(empty_generated_columns()) - } - - columns <- tibble::tibble( - model_family = "temporal", - variable_role = "predictor", - variable = temporal_decompositions$predictor, - component = temporal_decompositions$component, - lag = temporal_decompositions$lag, - column_role = "temporal_component", - column = temporal_decompositions$column, - source_column = temporal_decompositions$predictor + required_fields <- c( + "target", "predictor", "temporal_component", "lag", + "model_family", "column_role", "variable_role", "source_column" ) - - attach_generated_column_specs(columns) -} - -apim_generated_columns <- function(apim_predictors) { - if (is.null(apim_predictors) || nrow(apim_predictors) == 0) { - return(empty_generated_columns()) - } - - columns <- dplyr::bind_rows( - tibble::tibble( - model_family = "apim", - variable_role = "predictor", - variable = apim_predictors$predictor, - component = apim_predictors$component, - lag = apim_predictors$lag, - column_role = "actor", - column = apim_predictors$actor_column, - source_column = apim_predictors$source_column - ), - tibble::tibble( - model_family = "apim", - variable_role = "predictor", - variable = apim_predictors$predictor, - component = apim_predictors$component, - lag = apim_predictors$lag, - column_role = "partner", - column = apim_predictors$partner_column, - source_column = apim_predictors$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 ) - ) - - attach_generated_column_specs(columns) -} - -dim_generated_columns <- function(dim_predictors) { - if (is.null(dim_predictors) || nrow(dim_predictors) == 0) { - return(empty_generated_columns()) } - columns <- dplyr::bind_rows( - tibble::tibble( - model_family = "dim", - variable_role = "predictor", - variable = dim_predictors$predictor, - component = dim_predictors$component, - lag = dim_predictors$lag, - column_role = "dyad_mean", - column = dim_predictors$mean_column, - source_column = dim_predictors$source_column - ), - tibble::tibble( - model_family = "dim", - variable_role = "predictor", - variable = dim_predictors$predictor, - component = dim_predictors$component, - lag = dim_predictors$lag, - column_role = "within_dyad_deviation", - column = dim_predictors$deviation_column, - source_column = dim_predictors$source_column - ) + 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 ) - attach_generated_column_specs(columns) -} - -dsm_generated_columns <- function(dsm_predictors, role_contrast_column, role_column) { - columns <- list() - - if (!is.null(role_contrast_column)) { - columns$role_contrast <- tibble::tibble( - model_family = "dsm", - variable_role = "role", - variable = role_column, - component = "raw", - lag = 0L, - column_role = "role_contrast", - column = role_contrast_column, - source_column = role_column - ) - } - - if (!is.null(dsm_predictors) && nrow(dsm_predictors) > 0) { - predictor_columns <- dplyr::bind_rows( - tibble::tibble( - model_family = "dsm", - variable_role = "predictor", - variable = dsm_predictors$predictor, - component = dsm_predictors$component, - lag = dsm_predictors$lag, - column_role = "dyad_mean", - column = dsm_predictors$mean_column, - source_column = dsm_predictors$source_column - ), - tibble::tibble( - model_family = "dsm", - variable_role = "predictor", - variable = dsm_predictors$predictor, - component = dsm_predictors$component, - lag = dsm_predictors$lag, - column_role = "dyad_difference", - column = dsm_predictors$difference_column, - source_column = dsm_predictors$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 ) - - columns$predictors <- predictor_columns } - columns <- dplyr::bind_rows(columns) + # Fail at the generation boundary if a plan has no matching specification. + invisible(attach_generated_column_specs(columns)) - if (nrow(columns) == 0) { - return(empty_generated_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 + ) } - attach_generated_column_specs(columns) + meta$generated_columns <- recorded_columns + attr(data, "dyadMLM") <- meta + data } attach_generated_column_specs <- function(columns) { @@ -302,6 +232,7 @@ attach_generated_column_specs <- function(columns) { "column_centering", "print_order", "column_pattern", + "short_column_pattern", "description" ) missing_spec <- !stats::complete.cases(out[spec_cols]) @@ -325,6 +256,11 @@ attach_generated_column_specs <- function(columns) { "_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], @@ -336,29 +272,46 @@ attach_generated_column_specs <- function(columns) { } generated_column_spec_lookup <- function() { - tibble::tribble( - ~model_family, ~variable_role, ~component, ~column_role, ~temporal_decomposition, ~dyadic_decomposition, ~column_centering, ~print_order, ~column_pattern, ~description, - "temporal", "predictor", "raw", "temporal_component", "none", "none", "none", 7L, ".dy_{pred}", "raw predictor values", - "temporal", "predictor", "cwp", "temporal_component", "within_person", "none", "none", 8L, ".dy_{pred}_cwp", "within-person predictor: momentary deviations from each person's usual level", - "temporal", "predictor", "cbp", "temporal_component", "between_person_grand_mean", "none", "none", 9L, ".dy_{pred}_cbp", "between-person predictor: stable differences from the average person's usual level", - "apim", "predictor", "raw", "actor", "none", "none", "none", 10L, ".dy_{pred}_actor", "APIM actor predictor: actor's original predictor values", - "apim", "predictor", "raw", "partner", "none", "none", "none", 11L, ".dy_{pred}_partner", "APIM partner predictor: partner's original predictor values", - "apim", "predictor", "cwp", "actor", "within_person", "none", "none", 12L, ".dy_{pred}_cwp_actor", "APIM within-person actor predictor: actor's momentary deviations from their usual level", - "apim", "predictor", "cwp", "partner", "within_person", "none", "none", 13L, ".dy_{pred}_cwp_partner", "APIM within-person partner predictor: partner's momentary deviations from their usual level", - "apim", "predictor", "cbp", "actor", "between_person_grand_mean", "none", "none", 14L, ".dy_{pred}_cbp_actor", "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, ".dy_{pred}_cbp_partner", "APIM between-person partner predictor: partner's stable difference from the average person's usual level", - "dsm", "role", "raw", "role_contrast", "none", "role_contrast", "none", 19L, ".dy_dsm_role_contrast", "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, ".dy_{pred}_dyad_mean_gmc", "dyad-mean predictor: dyad's average predictor level, grand-mean centered", - "dim", "predictor", "raw", "within_dyad_deviation", "none", "within_dyad_deviation", "none", 21L, ".dy_{pred}_within_dyad_dev", "DIM within-dyad member-deviation predictor: member's difference from the dyad mean", - "dim", "predictor", "cwp", "dyad_mean", "within_person", "dyad_mean", "none", 22L, ".dy_{pred}_cwp_dyad_mean", "within-person dyad-mean predictor: shared momentary deviations in the dyad", - "dim", "predictor", "cwp", "within_dyad_deviation", "within_person", "within_dyad_deviation", "none", 23L, ".dy_{pred}_cwp_within_dyad_dev", "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, ".dy_{pred}_cbp_dyad_mean", "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, ".dy_{pred}_cbp_within_dyad_dev", "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, ".dy_{pred}_dyad_mean_gmc", "dyad-mean predictor: dyad's average predictor level, grand-mean centered", - "dsm", "predictor", "raw", "dyad_difference", "none", "dyad_difference", "none", 21L, ".dy_{pred}_within_dyad_diff", "DSM signed predictor difference: first declared role minus second declared role", - "dsm", "predictor", "cwp", "dyad_mean", "within_person", "dyad_mean", "none", 22L, ".dy_{pred}_cwp_dyad_mean", "within-person dyad-mean predictor: shared momentary deviations in the dyad", - "dsm", "predictor", "cwp", "dyad_difference", "within_person", "dyad_difference", "none", 23L, ".dy_{pred}_cwp_within_dyad_diff", "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, ".dy_{pred}_cbp_dyad_mean", "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, ".dy_{pred}_cbp_within_dyad_diff", "DSM between-person signed predictor difference: first declared role minus second declared role" + # 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 } diff --git a/R/dyadMLM-package.R b/R/dyadMLM-package.R new file mode 100644 index 00000000..959a117c --- /dev/null +++ b/R/dyadMLM-package.R @@ -0,0 +1,26 @@ +# Package-level documentation. The title, authors, and links are taken from +# DESCRIPTION through roxygen2's "_PACKAGE" sentinel. + +#' @description +#' `dyadMLM` validates and prepares cross-sectional and intensive longitudinal +#' dyadic data for multilevel modeling. It creates model-ready variables for +#' APIMs, DIMs, and DSMs and provides supporting post-estimation tools. +#' +#' @section Main functions: +#' - [prepare_dyad_data()] validates long-format dyadic data and creates +#' model-ready variables. +#' - [compare_nested_models()] compares compatible nested `glmmTMB` +#' models fitted to equivalent data. +#' - [recover_exchangeable_covariance()] converts exchangeable +#' shared/difference covariance structures to member-level quantities. +#' +#' @section Example data: +#' See [dyads_cross] and [dyads_ild] for Gaussian examples, and +#' [dyads_nbinom_cross] and [dyads_nbinom_ild] for negative-binomial examples. +#' +#' @section Getting started: +#' See `vignette("getting-started", package = "dyadMLM")` for an overview. +#' The APIM, DIM, and DSM vignettes provide model-specific examples. +#' +#' @keywords internal +"_PACKAGE" diff --git a/R/infer_dyad_compositions.R b/R/infer_dyad_compositions.R index 7cdefe74..f450c2dd 100644 --- a/R/infer_dyad_compositions.R +++ b/R/infer_dyad_compositions.R @@ -4,8 +4,8 @@ #' `dyadMLM_data` object. #' #' @param data A `dyadMLM_data` object returned by [validate_dyad_data()]. -#' @param seed Optional seed for random `.dy_member_contrast_*` sign assignment in -#' exchangeable dyads. If `NULL`, the current R session's RNG state is used. +#' @param seed Optional seed for random `.member_contrast_*` sign assignment. +#' If `NULL`, the current R session's RNG state is used. #' @param keep_compositions Optional observed dyad compositions to keep #' before exchangeability overrides and pooling. #' @param set_exchangeable_compositions Optional dyad compositions to treat as @@ -13,28 +13,62 @@ #' @param pool_compositions Optional named list that pools exchangeable dyad #' compositions into user-named final composition labels. Each pool must #' resolve to at least two distinct observed compositions. +#' @param short_colnames Whether to use shorter composition-dependent generated +#' column names when the final data contain one composition. +#' @param include_arbitrary_member_contrast Whether to also generate arbitrary +#' `.member_contrast_*` columns for distinguishable compositions without +#' changing their composition metadata, roles, or indicators. #' -#' @return A `dyadMLM_data` object with added `.dy_composition` and -#' `.dy_composition_role` factor columns, `.dy_is_*` numeric indicator columns, -#' composition-specific numeric `.dy_member_contrast_*` columns coded `-1` and -#' `1` for the two members of matching exchangeable dyads and `0` otherwise, +#' @return A `dyadMLM_data` object with added `.composition` and +#' `.composition_role` factor columns, `.is_*` numeric indicator columns, +#' composition-specific numeric `.member_contrast_*` columns coded `-1` and +#' `1` for the two members of each matching composition and `0` otherwise, #' and dyad composition metadata. #' #' @keywords internal infer_dyad_compositions <- function(data, seed = NULL, keep_compositions = NULL, set_exchangeable_compositions = NULL, - pool_compositions = NULL) { + pool_compositions = NULL, + short_colnames = TRUE, + include_arbitrary_member_contrast = FALSE) { if (!inherits(data, "dyadMLM_data")) { stop( "`data` must be a `dyadMLM_data` object returned by `prepare_dyad_data()`.", call. = FALSE ) } + if (!is.logical(short_colnames) || + length(short_colnames) != 1L || + is.na(short_colnames)) { + stop("`short_colnames` must be `TRUE` or `FALSE`.", call. = FALSE) + } + if (!is.logical(include_arbitrary_member_contrast) || + length(include_arbitrary_member_contrast) != 1L || + is.na(include_arbitrary_member_contrast)) { + stop( + "`include_arbitrary_member_contrast` must be `TRUE` or `FALSE`.", + call. = FALSE + ) + } meta_data <- attr(data, "dyadMLM") group_name <- meta_data$dyad member_name <- meta_data$member + # These retained columns are created before the composition-dependent names + # are known, so protect them from input collisions before either is written. + fixed_composition_column_plan <- tibble::tibble( + target = c(dyad_composition_col, dyad_composition_role_col), + predictor = NA_character_, + temporal_component = "none", + lag = 0L, + model_family = "composition", + column_role = c("composition", "composition_role"), + variable_role = c("composition", "composition_role"), + source_column = NA_character_ + ) + validate_generated_column_plan(data, fixed_composition_column_plan) + # The case if no role column was provided if (is.null(meta_data$role)) { if (!is.null(keep_compositions)) { @@ -81,9 +115,12 @@ infer_dyad_compositions <- function(data, seed = NULL, keep_compositions = NULL, data[[dyad_diff_col]] <- ifelse(data[[dyad_arbitrary_role_col]] == "arbitrary_1", -1, 1) - # convert to factors, sanitize role names, construct .dy_is_{indicator} variables. - # remove temporary cols, create composition-specific diff cols for exchangeable dyads. - data <- finalize_composition_columns(data) + # Finalize factors and construct the generated composition columns. + data <- finalize_composition_columns( + data, + short_colnames, + fixed_composition_column_plan + ) return(data) } @@ -117,7 +154,7 @@ infer_dyad_compositions <- function(data, seed = NULL, keep_compositions = NULL, .groups = "drop" ) |> dplyr::mutate( - .dy_composition = .data$.dy_raw_composition, + "{dyad_composition_col}" := .data[[dyad_raw_composition_col]], .dy_pool_member = NA_character_ ) @@ -178,8 +215,8 @@ infer_dyad_compositions <- function(data, seed = NULL, keep_compositions = NULL, by = group_name ) - # Only exchangeable dyads need arbitrary labels for their difference - # contrasts. + # Assign exchangeable dyads first so their seeded assignments remain + # unchanged when optional distinguishable contrasts are requested. exchangeable_data <- data[data[[dyad_type_col]] == "exchangeable", , drop = FALSE] arbitrary_roles <- assign_arbitrary_member_roles( exchangeable_data, @@ -188,6 +225,21 @@ infer_dyad_compositions <- function(data, seed = NULL, keep_compositions = NULL, seed = seed ) + if (include_arbitrary_member_contrast) { + distinguishable_data <- + data[data[[dyad_type_col]] == "distinguishable", , drop = FALSE] + distinguishable_arbitrary_roles <- assign_arbitrary_member_roles( + distinguishable_data, + group_name = group_name, + member_name = member_name, + seed = seed + ) + arbitrary_roles <- dplyr::bind_rows( + arbitrary_roles, + distinguishable_arbitrary_roles + ) + } + data <- dplyr::left_join( data, arbitrary_roles, @@ -203,9 +255,13 @@ infer_dyad_compositions <- function(data, seed = NULL, keep_compositions = NULL, ) # Add a temporary pooled contrast, then expand it into one contrast column - # per exchangeable composition in finalize_composition_columns(). + # per selected composition in finalize_composition_columns(). + needs_member_contrast <- + data[[dyad_type_col]] == "exchangeable" | + (include_arbitrary_member_contrast & + data[[dyad_type_col]] == "distinguishable") data[[dyad_diff_col]] <- ifelse( - data[[dyad_type_col]] == "exchangeable", + needs_member_contrast, ifelse(data[[dyad_arbitrary_role_col]] == "arbitrary_1", -1, 1), 0 ) @@ -216,9 +272,12 @@ infer_dyad_compositions <- function(data, seed = NULL, keep_compositions = NULL, data[[dyad_type_source_col]] <- NULL data[[dyad_pool_member_col]] <- NULL - # convert to factors, sanitize role names, construct .dy_is_{indicator} variables. - # remove temporary cols, create composition-specific diff cols for exchangeable dyads. - data <- finalize_composition_columns(data) + # Finalize factors and construct the generated composition columns. + data <- finalize_composition_columns( + data, + short_colnames, + fixed_composition_column_plan + ) data } @@ -472,7 +531,7 @@ apply_pool_compositions <- function(dyad_roles, pool_compositions) { ## subsetting all rows **within the current pooling step**. is_pooled <- dyad_roles[[dyad_composition_col]] %in% resolved_compositions_to_pool - # Before overwriting .dy_composition, copy the old composition into .dy_pool_member. + # Retain each row's source composition before assigning the pool label. dyad_roles[[dyad_pool_member_col]][is_pooled] <- dyad_roles[[dyad_composition_col]][is_pooled] # Now replace the current composition with the pool name. @@ -485,45 +544,102 @@ apply_pool_compositions <- function(dyad_roles, pool_compositions) { } -finalize_composition_columns <- function(data) { +finalize_composition_columns <- function( + data, + short_colnames, + fixed_composition_column_plan + ) { # Convert to factors before returning. data[[dyad_composition_col]] <- factor(data[[dyad_composition_col]]) data[[dyad_composition_role_col]] <- factor(data[[dyad_composition_role_col]]) - # This was only needed for contrast construction, we remove it. + meta_data <- attr(data, "dyadMLM") + # Short names omit the composition label. They are unambiguous only when + # filtering and pooling leave one final composition; with more than one, + # short names would be ambiguous and therefore are not allowed. + has_single_composition <- nrow(meta_data$dyad_compositions) == 1L + use_short_composition_colnames <- + short_colnames && has_single_composition + + # Store the resolved choice so later lookup and printing use the names that + # were actually created, rather than the user's original request. + meta_data$short_colnames <- use_short_composition_colnames + attr(data, "dyadMLM") <- meta_data + + # The arbitrary role is only needed while constructing member contrasts. data[[dyad_arbitrary_role_col]] <- NULL - # These named vectors map the labels in the data to safe column suffixes. - # Only exchangeable compositions have a non-zero member contrast and - # therefore need a composition-specific contrast column. - composition_role_suffixes <- make_dyad_suffixes( - data[[dyad_composition_role_col]] - ) - exchangeable_composition_suffixes <- make_dyad_suffixes( - data[[dyad_composition_col]][data[[dyad_diff_col]] != 0] - ) - # Build the exact output names once and reuse them for validation and writing. - composition_role_labels <- sort(names(composition_role_suffixes)) - composition_indicator_columns <- paste0( - dyad_reserved_prefix, - "is_", - unname(composition_role_suffixes[composition_role_labels]) - ) + composition_role_labels <- sort(unique( + as.character(data[[dyad_composition_role_col]]) + )) + if (use_short_composition_colnames && + meta_data$dyad_compositions$dyad_type[[1L]] == "exchangeable") { + composition_indicator_columns <- paste0( + dyad_retained_prefix, + "is_exchangeable" + ) + } else if (use_short_composition_colnames) { + # With one distinguishable composition, the observed role alone identifies + # each indicator; the composition portion of the label is redundant. + observed_role_labels <- as.character(data[[meta_data$role]])[ + match( + composition_role_labels, + as.character(data[[dyad_composition_role_col]]) + ) + ] + observed_role_suffixes <- make_dyad_suffixes( + observed_role_labels, + label_type = "role labels", + rename_hint = "role labels" + ) + composition_indicator_columns <- paste0( + dyad_retained_prefix, + "is_", + unname(observed_role_suffixes[observed_role_labels]) + ) + } else { + composition_role_suffixes <- make_dyad_suffixes( + composition_role_labels + ) + composition_indicator_columns <- paste0( + dyad_retained_prefix, + "is_", + unname(composition_role_suffixes[composition_role_labels]) + ) + } names(composition_indicator_columns) <- composition_role_labels - exchangeable_compositions <- sort(names(exchangeable_composition_suffixes)) - member_contrast_columns <- paste0( - dyad_reserved_prefix, - "member_contrast_", - unname(exchangeable_composition_suffixes[exchangeable_compositions]), - "_arbitrary" - ) - names(member_contrast_columns) <- exchangeable_compositions + # Only compositions with non-zero member contrasts need a contrast column. + contrast_composition_labels <- sort(unique(as.character( + data[[dyad_composition_col]][data[[dyad_diff_col]] != 0] + ))) + member_contrast_columns <- character(length(contrast_composition_labels)) + if (length(contrast_composition_labels) > 0L) { + if (use_short_composition_colnames) { + member_contrast_columns <- paste0( + dyad_retained_prefix, + "member_contrast_arbitrary" + ) + } else { + contrast_composition_suffixes <- make_dyad_suffixes( + contrast_composition_labels + ) + member_contrast_columns <- paste0( + dyad_retained_prefix, + "member_contrast_", + unname( + contrast_composition_suffixes[contrast_composition_labels] + ), + "_arbitrary" + ) + } + } + names(member_contrast_columns) <- contrast_composition_labels - # Shape: one row per column that this function is about to create. The - # descriptive fields are used only to make collision errors informative. + # Use one row per column for both pre-write collision validation and the + # generated-column metadata recorded after all columns exist. composition_column_plan <- tibble::tibble( target = c( unname(composition_indicator_columns), @@ -536,11 +652,19 @@ finalize_composition_columns <- function(data) { column_role = c( rep("composition_indicator", length(composition_indicator_columns)), rep("member_contrast", length(member_contrast_columns)) + ), + variable_role = c( + rep("composition_role", length(composition_indicator_columns)), + rep("composition", length(member_contrast_columns)) + ), + source_column = c( + rep(dyad_composition_role_col, length(composition_indicator_columns)), + rep(dyad_composition_col, length(member_contrast_columns)) ) ) validate_generated_column_plan(data, composition_column_plan) - # Create numeric indicator columns .dy_is_{composition_role} + # Create numeric indicator columns using the exact planned names. for (composition_role in composition_role_labels) { composition_indicator_column <- composition_indicator_columns[[composition_role]] @@ -552,19 +676,27 @@ finalize_composition_columns <- function(data) { } # Composition-specific member contrasts let mixed-composition models target - # each exchangeable composition. - for (composition in exchangeable_compositions) { - row_has_composition <- - as.character(data[[dyad_composition_col]]) == composition - member_contrast_column <- member_contrast_columns[[composition]] + # each selected composition. + for (composition_label in contrast_composition_labels) { + row_matches_composition <- + as.character(data[[dyad_composition_col]]) == composition_label + member_contrast_column <- member_contrast_columns[[composition_label]] data[[member_contrast_column]] <- ifelse( - row_has_composition, + row_matches_composition, data[[dyad_diff_col]], 0 ) } data[[dyad_diff_col]] <- NULL + # Record the complete composition stage only after every column exists. + data <- record_generated_columns( + data, + dplyr::bind_rows( + fixed_composition_column_plan, + composition_column_plan + ) + ) data } diff --git a/R/prepare_dyad_data.R b/R/prepare_dyad_data.R index 7b1cc2e6..3baf2a88 100644 --- a/R/prepare_dyad_data.R +++ b/R/prepare_dyad_data.R @@ -36,8 +36,8 @@ #' model-ready columns should be created. Requires `time` to be a finite, #' integer-valued numeric measurement index. Lagging respects the dyad and #' member structure, matches observations at exactly `time - 1`, and does not -#' bridge missing occasions. Only raw and within-person predictors are -#' lagged. Stable between-person versions are not. +#' bridge missing occasions. Eligible raw, within-person, and APIM GMC +#' variants are lagged; stable between-person variants are not. #' @param model_types Model-ready column families to construct. Can contain one #' or more of `"apim"`, `"dim"`, and `"dsm"`. `"apim"` creates #' actor and partner predictors. `"dim"` creates dyad-mean and @@ -74,6 +74,10 @@ #' for example `"female_x_male"`, `"female-male"`, `"female_male"`, or #' `"female male"`, in arbitrary order. #' To set multiple compositions, use a character vector of such strings. +#' Unlike `include_arbitrary_member_contrast`, this reclassifies the selected +#' compositions as exchangeable and changes their composition-role coding and +#' indicators, which is required for composition pooling and DIM +#' compatibility. #' @param keep_compositions Optional observed dyad compositions to keep #' before exchangeability overrides and pooling. Requires `role`. Composition #' references use the same format as `set_exchangeable_compositions`. `NULL` @@ -96,18 +100,41 @@ #' is applied. `"error"` stops with an error and `"drop"` removes the entire #' dyad. Conflicting non-missing roles always cause an error. Ignored when no #' `role` column is supplied. -#' @param seed Optional seed for random `.dy_member_contrast_*` sign assignment -#' in exchangeable dyads. If `NULL`, the current R session's RNG state is used. +#' @param seed Optional seed for random `.member_contrast_*` sign assignment. +#' If `NULL`, the current R session's RNG state is used. +#' @param short_colnames Whether to use shorter composition-dependent generated +#' column names when the final data contain one composition. The default `TRUE` +#' omits the redundant composition label from `.is_*` and +#' `.member_contrast_*` names. `FALSE` always retains composition-qualified +#' names. Other generated column names are unaffected. +#' @param include_arbitrary_member_contrast Whether to also generate arbitrary +#' `.member_contrast_*` columns for distinguishable compositions. The default +#' `FALSE` generates these columns only for exchangeable compositions. +#' `TRUE` retains distinguishable composition metadata, composition roles, +#' and role indicators. It only adds the contrast needed to fit an +#' exchangeability-constrained random-effects model to the same prepared +#' data. Use `set_exchangeable_compositions` instead to reclassify +#' compositions for pooling or DIM compatibility. +#' @param add_apim_gmc_predictors Whether to add APIM GMC variants for numeric +#' predictors. `TRUE` retains the raw columns and adds `.{pred}_gmc` plus its +#' actor and partner versions, centered over all retained non-missing values +#' after filtering. Lagged variants use the same mean. Mixed non-numeric +#' predictors remain raw and are listed in one warning. In longitudinal data, +#' the mean is observation-weighted. Requires `"apim"` in `model_types`, at +#' least one numeric predictor, and resolved `temporal_decomposition = "none"`. +#' Do not use raw and GMC variants together in a model with an intercept. #' #' @return The original data as a tibble with class `dyadMLM_data`, -#' `.dy_composition` and `.dy_composition_role` factor columns, -#' `.dy_is_*` numeric indicator columns, composition-specific -#' numeric `.dy_member_contrast_*` columns coded `-1` and `1` for the two -#' members of matching exchangeable dyads and `0` otherwise, and a `dyadMLM` -#' attribute containing structural metadata, `dyad_compositions`, and +#' `.composition` and `.composition_role` factor columns, +#' `.is_*` numeric indicator columns, and numeric +#' `.member_contrast_*` columns coded `-1` and `1` for the two members of +#' each matching composition and `0` otherwise. With one final composition, +#' their default names omit the composition label. The `dyadMLM` attribute +#' contains structural metadata, `dyad_compositions`, and #' predictor metadata such as `temporal_decompositions`, `lag1_predictors`, #' `apim_predictors`, and `dim_predictors`, as well as `dsm_predictors` and -#' `dsm_role_order` when applicable. +#' `dsm_role_order` when applicable. The `generated_columns` table records each +#' package-generated column retained in the returned data. #' #' @examples #' data <- data.frame( @@ -180,7 +207,10 @@ prepare_dyad_data <- function( pool_compositions = NULL, incomplete_dyads = c("error", "drop"), missing_role = c("error", "drop"), - seed = NULL + seed = NULL, + short_colnames = TRUE, + include_arbitrary_member_contrast = FALSE, + add_apim_gmc_predictors = FALSE ) { model_types <- normalize_model_types(model_types) @@ -188,6 +218,24 @@ prepare_dyad_data <- function( incomplete_dyads <- rlang::arg_match(incomplete_dyads) missing_role <- rlang::arg_match(missing_role) + if (!is.logical(add_apim_gmc_predictors) || + length(add_apim_gmc_predictors) != 1L || + is.na(add_apim_gmc_predictors)) { + stop( + "`add_apim_gmc_predictors` must be `TRUE` or `FALSE`.", + call. = FALSE + ) + } + if (add_apim_gmc_predictors && !"apim" %in% model_types) { + stop( + paste0( + "`add_apim_gmc_predictors = TRUE` requires that `model_types` ", + "includes \"apim\"." + ), + call. = FALSE + ) + } + out <- validate_dyad_data( data = data, dyad = {{ dyad }}, @@ -203,12 +251,60 @@ prepare_dyad_data <- function( missing_role = missing_role ) + if (add_apim_gmc_predictors) { + meta_data <- attr(out, "dyadMLM") + if (meta_data$temporal_decomposition != "none") { + stop( + paste0( + "`add_apim_gmc_predictors = TRUE` requires ", + "`temporal_decomposition = \"none\"` after `\"auto\"` is resolved." + ), + call. = FALSE + ) + } + + predictors <- meta_data$predictors + predictor_is_numeric <- logical(length(predictors)) + for (predictor_index in seq_along(predictors)) { + predictor <- predictors[[predictor_index]] + predictor_is_numeric[[predictor_index]] <- is.numeric(out[[predictor]]) + } + + numeric_predictors <- predictors[predictor_is_numeric] + if (length(numeric_predictors) == 0L) { + stop( + paste0( + "`add_apim_gmc_predictors = TRUE` requires at least one numeric ", + "variable selected by `predictors`." + ), + call. = FALSE + ) + } + + non_numeric_predictors <- predictors[!predictor_is_numeric] + if (length(non_numeric_predictors) > 0L) { + warning( + paste0( + "`add_apim_gmc_predictors = TRUE` was not applied to non-numeric ", + "predictor(s): ", + paste0("`", non_numeric_predictors, "`", collapse = ", "), + ". Their raw actor and partner columns were retained. Recode ", + "predictors explicitly as numeric only when grand-mean centering ", + "is substantively meaningful." + ), + call. = FALSE + ) + } + } + out <- infer_dyad_compositions( out, seed = seed, keep_compositions = keep_compositions, set_exchangeable_compositions = set_exchangeable_compositions, - pool_compositions = pool_compositions + pool_compositions = pool_compositions, + short_colnames = short_colnames, + include_arbitrary_member_contrast = include_arbitrary_member_contrast ) # Validate model compatibilities @@ -216,7 +312,10 @@ prepare_dyad_data <- function( validate_dsm_compatibility(out) } - out <- center_predictors(out) + out <- center_predictors( + out, + add_apim_gmc_predictors = add_apim_gmc_predictors + ) out <- add_temporal_lag_columns(out) if ("dim" %in% model_types) { diff --git a/R/print_dyadMLM_data.R b/R/print_dyadMLM_data.R index 79d79075..17c17e2b 100644 --- a/R/print_dyadMLM_data.R +++ b/R/print_dyadMLM_data.R @@ -1,8 +1,24 @@ #' @export print.dyadMLM_data <- function(x, ...) { + print_dyadMLM_header(x) + meta <- attr(x, "dyadMLM") + cat("# Added columns:\n") + print_added_columns(added_columns_for_print(x, meta)) + cat("#\n") - cat(pillar::style_subtle("# dyadMLM data\n")) + modified <- x + class(modified) <- class(modified)[class(modified) != "dyadMLM_data"] + print(modified, ...) + + # return original unchanged tibble + invisible(x) +} + +print_dyadMLM_header <- function(x, title = "dyadMLM data") { + meta <- attr(x, "dyadMLM") + + cat(pillar::style_subtle(paste0("# ", title, "\n"))) print_wrapped_comment_fields( fields = c( paste0("Rows: ", nrow(x)), @@ -62,17 +78,7 @@ print.dyadMLM_data <- function(x, ...) { } print_dyad_compositions(meta$dyad_compositions) - - cat("# Added columns:\n") - print_added_columns(added_columns_for_print(x, meta)) - cat("#\n") - - modified <- x - class(modified) <- class(modified)[class(modified) != "dyadMLM_data"] - print(modified, ...) - - # return original unchanged tibble - invisible(x) + invisible(NULL) } print_dyad_compositions <- function(dyad_compositions) { @@ -126,27 +132,9 @@ print_dyad_compositions <- function(dyad_compositions) { } added_columns_for_print <- function(x, meta) { - fixed_added_columns <- tibble::tribble( - ~column_pattern, ~description, - ".dy_composition", "inferred dyad composition", - ".dy_composition_role", "composition-specific member role", - ".dy_is_{comp-role}", "composition-role indicator columns", - ".dy_member_contrast_{comp}_arbitrary", "composition-specific member contrasts with arbitrary direction; 0 for distinguishable dyads or other exchangeable compositions" - ) - show_fixed_added_columns <- c( - dyad_composition_col %in% names(x), - dyad_composition_role_col %in% names(x), - any(startsWith(names(x), paste0(dyad_reserved_prefix, "is_"))), - any(startsWith( - names(x), - paste0(dyad_reserved_prefix, "member_contrast_") - )) - ) - added_columns <- fixed_added_columns[show_fixed_added_columns, ] - # Users may remove generated columns while keeping the dyadMLM metadata. - # Only advertise generated model columns that are still present in the data. - generated_column_specs <- dyad_generated_columns(meta) |> + # Only advertise generated columns that are still present in the data. + dyad_generated_columns(meta) |> dplyr::filter(.data$column %in% names(x)) |> # Avoid repeated descriptions when several generated columns share a family. dplyr::distinct( @@ -154,16 +142,8 @@ added_columns_for_print <- function(x, meta) { .data$column_pattern, .data$description ) |> - dplyr::arrange(.data$print_order) - - if (nrow(generated_column_specs) > 0) { - added_columns <- dplyr::bind_rows( - added_columns, - generated_column_specs[, c("column_pattern", "description")] - ) - } - - added_columns + dplyr::arrange(.data$print_order) |> + dplyr::select("column_pattern", "description") } print_added_columns <- function(added_columns) { diff --git a/R/summary_dyadMLM_data.R b/R/summary_dyadMLM_data.R new file mode 100644 index 00000000..fb31e470 --- /dev/null +++ b/R/summary_dyadMLM_data.R @@ -0,0 +1,19 @@ +#' Summarize prepared dyadic data +#' +#' Prints the dyadic structure followed by standard summaries for all columns. +#' +#' @param object A `dyadMLM_data` object returned by [prepare_dyad_data()]. +#' @param ... Arguments passed to [summary()]. +#' +#' @return Invisibly, the standard summary of all columns. +#' +#' @export +summary.dyadMLM_data <- function(object, ...) { + print_dyadMLM_header(object, title = "Summary of dyadMLM data") + cat("# Column summaries:\n") + + class(object) <- class(object)[class(object) != "dyadMLM_data"] + result <- summary(object, ...) + print(result) + invisible(result) +} diff --git a/R/utils-compositions.R b/R/utils-compositions.R index b5b1c8ae..e573f66e 100644 --- a/R/utils-compositions.R +++ b/R/utils-compositions.R @@ -11,12 +11,15 @@ dyad_composition_role_sep <- "_" # Label used when no role column is supplied. dyad_assumed_exchangeable_label <- "assumed_exchangeable" -# Prefix to be used for package-owned / reserved columns. +# Prefix reserved for temporary implementation columns. dyad_reserved_prefix <- ".dy_" -# Package generated columns will use the following names consistently -dyad_composition_col <- paste0(dyad_reserved_prefix, "composition") -dyad_composition_role_col <- paste0(dyad_reserved_prefix, "composition_role") +# 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") @@ -24,7 +27,7 @@ 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_reserved_prefix, "dsm_role_contrast") +dyad_dsm_role_contrast_col <- paste0(dyad_retained_prefix, "dsm_role_contrast") ############################################################################ # HELPER FUNCTIONS diff --git a/README.Rmd b/README.Rmd index 80a0e3e7..1d87b6a6 100644 --- a/README.Rmd +++ b/README.Rmd @@ -54,18 +54,16 @@ workflows, with models fitted primarily using `brms` ## Installation -You can install the released version of `dyadMLM` from CRAN with: +You can install the development version with: -``` r -install.packages("dyadMLM") +```{r eval = FALSE} +install.packages("dyadMLM", repos = c( + "https://pascal-kueng.r-universe.dev", + "https://cloud.r-project.org" + ) +) ``` -You can install the development version from GitHub with: - -``` r -# install.packages("pak") -pak::pak("Pascal-Kueng/dyadMLM") -``` ## Simple Cross-Sectional Example @@ -100,19 +98,19 @@ simple_apim <- glmmTMB::glmmTMB( closeness ~ # Gender-specific intercepts - 0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male + + 0 + .is_female + .is_male + # Gender-specific actor effects - .dy_provided_support_actor:.dy_is_female_x_male_female + - .dy_provided_support_actor:.dy_is_female_x_male_male + + .provided_support_actor:.is_female + + .provided_support_actor:.is_male + # Gender-specific partner effects - .dy_provided_support_partner:.dy_is_female_x_male_female + - .dy_provided_support_partner:.dy_is_female_x_male_male + + .provided_support_partner:.is_female + + .provided_support_partner:.is_male + # Dyad-level random effects represent the two members' # residual covariance structure - us(0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | coupleID), + us(0 + .is_female + .is_male | coupleID), # With the residual covariance represented by the dyad-level # random effects above, the Gaussian residual dispersion is fixed near zero. diff --git a/README.md b/README.md index e219c728..83d83ce3 100644 --- a/README.md +++ b/README.md @@ -44,17 +44,14 @@ DIM workflows, with models fitted primarily using `brms` ## Installation -You can install the released version of `dyadMLM` from CRAN with: +You can install the development version with: ``` r -install.packages("dyadMLM") -``` - -You can install the development version from GitHub with: - -``` r -# install.packages("pak") -pak::pak("Pascal-Kueng/dyadMLM") +install.packages("dyadMLM", repos = c( + "https://pascal-kueng.r-universe.dev", + "https://cloud.r-project.org" + ) +) ``` ## Simple Cross-Sectional Example @@ -86,13 +83,12 @@ print(prepared_data, n = 4) #> # female_x_male distinguishable 120 dyads #> # #> # Added columns: -#> # .dy_composition inferred dyad composition -#> # .dy_composition_role composition-specific member role -#> # .dy_is_{comp-role} composition-role indicator columns -#> # .dy_{pred}_actor APIM actor predictor: actor's original predictor -#> # values -#> # .dy_{pred}_partner APIM partner predictor: partner's original predictor -#> # values +#> # .composition inferred dyad composition +#> # .composition_role composition-specific member role +#> # .is_{role} composition-role indicator columns +#> # .{pred}_actor APIM actor predictor: actor's original predictor values +#> # .{pred}_partner APIM partner predictor: partner's original predictor +#> # values #> # #> # A tibble: 240 × 12 #> personID coupleID gender dyad_composition closeness provided_support @@ -102,9 +98,9 @@ print(prepared_data, n = 4) #> 3 3 2 female female_x_male 6.44 4.09 #> 4 4 2 male female_x_male 5.99 6.20 #> # ℹ 236 more rows -#> # ℹ 6 more variables: .dy_composition , .dy_composition_role , -#> # .dy_is_female_x_male_female , .dy_is_female_x_male_male , -#> # .dy_provided_support_actor , .dy_provided_support_partner +#> # ℹ 6 more variables: .composition , .composition_role , +#> # .is_female , .is_male , .provided_support_actor , +#> # .provided_support_partner ``` The prepared data contains the composition indicators and APIM @@ -117,19 +113,19 @@ simple_apim <- glmmTMB::glmmTMB( closeness ~ # Gender-specific intercepts - 0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male + + 0 + .is_female + .is_male + # Gender-specific actor effects - .dy_provided_support_actor:.dy_is_female_x_male_female + - .dy_provided_support_actor:.dy_is_female_x_male_male + + .provided_support_actor:.is_female + + .provided_support_actor:.is_male + # Gender-specific partner effects - .dy_provided_support_partner:.dy_is_female_x_male_female + - .dy_provided_support_partner:.dy_is_female_x_male_male + + .provided_support_partner:.is_female + + .provided_support_partner:.is_male + # Dyad-level random effects represent the two members' # residual covariance structure - us(0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | coupleID), + us(0 + .is_female + .is_male | coupleID), # With the residual covariance represented by the dyad-level # random effects above, the Gaussian residual dispersion is fixed near zero. diff --git a/_pkgdown.yml b/_pkgdown.yml index dd7e6963..94a3ce29 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -43,7 +43,8 @@ reference: - title: Main functions contents: - prepare_dyad_data - - compare_nested_glmmTMB_models + - summary.dyadMLM_data + - compare_nested_models - recover_exchangeable_covariance - title: Example data diff --git a/data-raw/dyads.R b/data-raw/dyads.R index ba28f8f4..c6e0ca99 100644 --- a/data-raw/dyads.R +++ b/data-raw/dyads.R @@ -173,6 +173,45 @@ support_by_day <- dplyr::bind_rows(support_day_rows) stable_effects <- dplyr::bind_rows(stable_effect_rows) residual_process <- dplyr::bind_rows(residual_rows) +############################################################################### +### MEMBER-SPECIFIC AR(1) RESIDUAL PROCESSES +############################################################################### + +# Female and male members have separate stationary AR(1) processes with the +# same marginal variability and deliberately similar persistence. +ar1_parameters <- tibble::tribble( + ~gender, ~ar1_sd, ~ar1_rho, + "female", 0.60, 0.55, + "male", 0.60, 0.50 +) + +set.seed(81029) +ar1_rows <- vector("list", nrow(persons)) + +for (person_index in seq_len(nrow(persons))) { + person <- persons[person_index, ] + parameters <- ar1_parameters[ + ar1_parameters$gender == person$gender, + ] + ar1_values <- numeric(length(diary_days)) + ar1_values[1L] <- stats::rnorm(1L, 0, parameters$ar1_sd) + innovation_sd <- parameters$ar1_sd * sqrt(1 - parameters$ar1_rho^2) + + for (day_index in 2:length(diary_days)) { + ar1_values[day_index] <- + parameters$ar1_rho * ar1_values[day_index - 1L] + + stats::rnorm(1L, 0, innovation_sd) + } + + ar1_rows[[person_index]] <- tibble::tibble( + personID = person$personID, + diaryday = diary_days, + ar1_residual = ar1_values + ) +} + +ar1_process <- dplyr::bind_rows(ar1_rows) + ############################################################################### ### OUTCOME FIXED EFFECTS ############################################################################### @@ -251,9 +290,10 @@ panel <- panel |> dyads_ild <- panel |> dplyr::left_join(residual_process, by = c("coupleID", "diaryday")) |> + dplyr::left_join(ar1_process, by = c("personID", "diaryday")) |> dplyr::mutate( closeness = expected_closeness + shared_residual + - member_contrast * difference_residual, + member_contrast * difference_residual + ar1_residual, gender = factor(gender, levels = c("female", "male")), dyad_composition = factor( dyad_composition, diff --git a/data/dyads_cross.rda b/data/dyads_cross.rda index 475f7714..04842d47 100644 Binary files a/data/dyads_cross.rda and b/data/dyads_cross.rda differ diff --git a/data/dyads_ild.rda b/data/dyads_ild.rda index 806335bd..8b68453c 100644 Binary files a/data/dyads_ild.rda and b/data/dyads_ild.rda differ diff --git a/dev/.gitignore b/dev/.gitignore index 1d8b9738..323b9c0a 100644 --- a/dev/.gitignore +++ b/dev/.gitignore @@ -1,3 +1,4 @@ *.pdf +*.html +!workshop/branding.html References - diff --git a/dev/backtransform.md b/dev/backtransform.md index de26d33e..b8a04af5 100644 --- a/dev/backtransform.md +++ b/dev/backtransform.md @@ -2,21 +2,23 @@ ## Status -This is the implementation specification for the first public covariance -back-transformation helper in `dyadMLM`. It records the decisions made for -v0.0.1 and the intended path to later model engines and more complex covariance -structures. +This is the implementation record for the first public covariance +back-transformation helper in `dyadMLM`. It records the decisions shipped in +v0.1.0 and the intended path to later model engines and more complex covariance +structures. The current code, generated documentation, and tests are +authoritative for exact API behavior. Public function name: ```r -exchangeable_rescov(model) +recover_exchangeable_covariance(model) ``` Extraction, matching, structural-zero alignment, and the numerical back-transformation are implemented for `glmmTMB` and single-response -`brmsfit` models. `exchangeable_rescov()` returns one named member-level -covariance result per matched shared/difference block pair. +`brmsfit` models. `recover_exchangeable_covariance()` returns one named +member-level covariance result per matched shared/difference block pair; its +returned S3 class remains `exchangeable_rescov`. ## Purpose @@ -24,7 +26,7 @@ Exchangeable DIMs and APIMs represent the two members' residuals through two independent random-effect blocks: - a **shared residual block**, which moves both members in the same direction; -- a **difference residual block**, identified by a `dyadMLM` `.dy_diff_*` +- a **difference residual block**, identified by a `dyadMLM` `.member_contrast_*` column, which moves them in opposite directions. The fitted variances of these blocks are useful computationally but are not the @@ -127,7 +129,7 @@ Sigma_member <- T %*% Sigma_score %*% t(T) independently of any model engine. The model-facing code is responsible only for discovering blocks and extracting `Sigma_score`. -## Public scope for v0.0.1 +## Public scope for v0.1.0 The function supports fitted `glmmTMB` and single-response `brmsfit` models containing one or more shared/difference random-effect pairs. The common block @@ -142,7 +144,7 @@ representation already supports: - explicit partial pairs and wholly omitted components, represented by structural zeros. -### Deliberate v0.0.1 restrictions +### Deliberate v0.1.0 restrictions The first version does not support: @@ -158,9 +160,9 @@ The first version does not support: `unstr(time = member, gr = pair_id)` residual structures that are already on the member scale. -Automatic matching requires untouched `dyadMLM` `.dy_diff_*` names and complete, -unambiguous pairs. Exact supplied pairs support custom indicator names and -constrained structures. +Automatic matching requires untouched `dyadMLM` `.member_contrast_*` names and +complete, unambiguous pairs. Exact supplied pairs support custom indicator +names and constrained structures. ## Source of structural information @@ -217,7 +219,7 @@ rather than guessing. Automatic matching starts from a canonical column matching ```text -.dy_diff_{composition}_arbitrary +.member_contrast_{composition}_arbitrary ``` The `{composition}` substring becomes the composition key. Every coefficient in @@ -230,7 +232,7 @@ For a composition-specific or mixed-composition model, the corresponding shared block contains exactly ```text -.dy_is_{composition} +.is_{composition} ``` For a single exchangeable composition, a generic intercept-and-slope block may @@ -263,16 +265,16 @@ hold: Grouping expressions are part of the pair key. Thus the same composition may produce separate results for `coupleID` and `coupleID:diaryday`. -Every discovered `.dy_diff_*` block must match exactly one shared block. Stop on -zero or multiple candidates; never silently drop or guess an ambiguous block. -If the model contains no supported `.dy_diff_*` block, explain that no -exchangeable shared/difference residual structure was found. +Every discovered `.member_contrast_*` block must match exactly one shared +block. Stop on zero or multiple candidates; never silently drop or guess an +ambiguous block. If the model contains no supported `.member_contrast_*` block, +explain that no exchangeable shared/difference residual structure was found. ### Renaming policy Users may freely name their original variables, grouping variables, outcomes, -and predictors. Automatic discovery requires the `dyadMLM`-generated -`.dy_is_*` and `.dy_diff_*` columns to retain their generated names. Explicit +and predictors. Automatic discovery requires the `dyadMLM`-generated `.is_*` +and `.member_contrast_*` columns to retain their generated names. Explicit matching also supports user-created indicator names because the user declares their meaning: @@ -383,13 +385,13 @@ and output while replacing only formula access and covariance extraction. ## Implementation sequence -The v0.0.1 numerical path is implemented: normalized extraction, automatic and +The v0.1.0 numerical path is implemented: normalized extraction, automatic and supplied matching, mixed compositions and grouping levels, partial and omitted components, structural-zero alignment, draw-wise back-transformation, `varcov`/`sdcor` construction, deterministic names, and boundary tests. The -remaining work is release-facing example and vignette polish; posterior summary -and print methods can be considered later without changing the draw-wise -result. +accepted release also includes the public orchestration and print methods. +Additional uncertainty summaries can be added later without changing the +draw-wise result. ## Test specification @@ -402,14 +404,14 @@ result. - A larger difference variance produces negative member correlation. - Zero shared or difference variance is handled as a valid boundary case. - The matrix is symmetric and positive semidefinite. -- Reversing the arbitrary sign of `.dy_diff_*` leaves the covariance result - unchanged. +- Reversing the arbitrary sign of `.member_contrast_*` leaves the covariance + result unchanged. - Forward and inverse transformations round-trip within numerical tolerance. ### Discovery and extraction tests - Single-composition model with an intercept shared block. -- Single-composition model with a `.dy_is_*` shared block. +- Single-composition model with a `.is_*` shared block. - Mixed model with two exchangeable compositions. - Mixed model containing both distinguishable and exchangeable blocks. - Pooled composition with a generated pool name. @@ -423,8 +425,8 @@ result. ### Failure tests -- No `.dy_diff_*` block. -- Unmatched `.dy_diff_*` block. +- No `.member_contrast_*` block. +- Unmatched `.member_contrast_*` block. - Multiple possible shared matches. - Shared and difference columns with inconsistent row support. - Renamed generated columns. diff --git a/dev/centering.md b/dev/centering.md index cfba2a5e..b16f24ed 100644 --- a/dev/centering.md +++ b/dev/centering.md @@ -8,27 +8,27 @@ decomposition, but expose model-specific predictor columns. Implemented scope: -- `model_type = c("apim", "dim", "dsm", "none")` -- `temporal_predictor_decomposition = c("auto", "time_2l", "none")` +- `model_types = c("apim", "dim", "dsm", "none")` +- `temporal_decomposition = c("auto", "2l", "none")` - two-level temporal predictor decomposition for ILD predictors - raw and temporally decomposed model-ready columns for APIM, DIM, and DSM +- optional GMC source, actor, and partner variants for raw APIM predictors - DIM dyad-mean and within-dyad-deviation columns - DIM currently requires one exchangeable dyad composition -- `model_type = "dsm"` for directional dyadic-score model data preparation +- `model_types = "dsm"` for directional dyadic-score model data preparation - DSM currently requires one distinguishable dyad composition - central generated-column metadata via `dyad_generated_columns()`, with one row per generated temporal, APIM, DIM, or DSM column Reserved for later: -- `temporal_predictor_decomposition = "time_3l"` for EMA/day/burst workflows +- `temporal_decomposition = "3l"` for EMA/day/burst workflows with an explicit higher temporal unit -- grand-mean-only centering as a separate user option - automatic inference of 3-level decomposition from the fitted model structure - multiple-composition DSM support - explicit multivariate or SEM-oriented dyad-score preparation -`time_2l` refers to the predictor decomposition over time, not to the full +`"2l"` refers to the predictor decomposition over time, not to the full random-effects structure of the fitted model. ## Pipeline @@ -39,32 +39,34 @@ random-effects structure of the fitted model. validate_dyad_data() infer_dyad_compositions() center_predictors() -add_temporal_lag_columns() # lag_predictors, when requested -add_actor_partner_columns() # "apim" in model_type -add_dyad_individual_columns() # "dim" in model_type -add_dyadic_score_columns() # "dsm" in model_type +add_temporal_lag_columns() # lag1_predictors, when requested +add_actor_partner_columns() # "apim" in model_types +add_dyad_individual_columns() # "dim" in model_types +add_dyadic_score_columns() # "dsm" in model_types ``` The resolved temporal predictor decomposition choice is stored in -`attr(data, "dyadMLM")$temporal_predictor_decomposition`. -`temporal_predictor_decomposition = "auto"` resolves to `time_2l` when both `time` and -`predictors` are supplied, and to `none` otherwise. +`attr(data, "dyadMLM")$temporal_decomposition`. +`temporal_decomposition = "auto"` resolves to `"2l"` when both `time` and +`predictors` are supplied, and to `"none"` otherwise. Only `predictors` are transformed. Outcomes remain unchanged and are selected later in the model formula. -`temporal_predictor_decomposition` controls predictor pre-decomposition over +`temporal_decomposition` controls predictor pre-decomposition over time. DIM and DSM apply dyadic predictor-score construction afterward; raw dyad means are centered around the grand mean of dyad means or observed dyad-occasion means. ## Centering +### Temporal decomposition + For each time-varying predictor `x`, `center_predictors()` creates: ```r -.dy_x_cwp = x - person_mean(x) -.dy_x_cbp = person_mean(x) - grand_mean(person_mean(x)) +.x_cwp = x - person_mean(x) +.x_cbp = person_mean(x) - grand_mean(person_mean(x)) ``` The grand mean is computed over person means, not over all observed rows. This @@ -73,7 +75,7 @@ observed measurement occasions. Missing values: -- missing raw values remain missing in `.dy_x_cwp` +- missing raw values remain missing in `.x_cwp` - person means ignore missing raw values - if a person has no observed predictor values, both components are missing for that person @@ -81,38 +83,50 @@ Missing values: The metadata table is: ```r -attr(data, "dyadMLM")$temporal_predictor_decompositions +attr(data, "dyadMLM")$temporal_decompositions ``` with one row for the raw predictor and one row per constructed temporal -component. When `lag_predictors` is supplied, lag-1 raw and CWP records are -added with `lag = 1`; unlagged records use `lag = 0`. +component. When `lag1_predictors` is supplied, lag-1 raw, CWP, and requested +GMC records are added with `lag = 1`; unlagged records use `lag = 0`. -Generated `.dy_*_cwp` and `.dy_*_cbp` columns also appear in the normalized +Generated `.{pred}_cwp` and `.{pred}_cbp` columns also appear in the normalized generated-column table returned by `dyad_generated_columns()`. Raw source records are excluded from the temporal part of that table because they are not package-generated columns. Their model-specific APIM, DIM, or DSM columns are included. +### Grand-mean-centered APIM predictors + +With resolved temporal decomposition `"none"`, +`add_apim_gmc_predictors = TRUE` retains raw columns and adds `.x_gmc` plus its +actor and partner variants for numeric predictors. The mean uses all retained +non-missing observations after filtering; all-missing predictors remain `NA`. +Mixed non-numeric predictors remain raw and are listed in one warning. + +The mean is pooled across roles and compositions and observation-weighted in +longitudinal data. Lagged GMC columns use the same mean. Do not include raw and +GMC variants together in a model with an intercept. + ## APIM Columns -`add_actor_partner_columns()` reads `temporal_predictor_decompositions` and creates APIM +`add_actor_partner_columns()` reads `temporal_decompositions` and creates APIM columns. For raw predictors: ```r -.dy_x_actor -.dy_x_partner +.x_actor +.x_partner ``` -For `time_2l` predictors, the raw columns above are retained alongside: +For `"2l"` predictors, the raw columns above are retained alongside: ```r -.dy_x_cwp_actor -.dy_x_cwp_partner -.dy_x_cbp_actor -.dy_x_cbp_partner +.x_cwp_actor +.x_cwp_partner +.x_cbp_actor +.x_cbp_partner ``` Partner values are matched within dyad for cross-sectional data and within @@ -127,15 +141,15 @@ attr(data, "dyadMLM")$apim_predictors ## DIM Columns -`add_dyad_individual_columns()` also reads `temporal_predictor_decompositions`, but it +`add_dyad_individual_columns()` also reads `temporal_decompositions`, but it does not depend on APIM actor/partner columns. DIM columns are computed directly from grouped dyad means. For within-person components, the decomposition level is dyad-time: ```r -.dy_x_cwp_dyad_mean -.dy_x_cwp_within_dyad_dev +.x_cwp_dyad_mean +.x_cwp_within_dyad_dev ``` For between-person components, the decomposition level is dyad. The @@ -143,15 +157,15 @@ implementation first reduces to one row per dyad-member so members are not weighted by the number of observed days: ```r -.dy_x_cbp_dyad_mean -.dy_x_cbp_within_dyad_dev +.x_cbp_dyad_mean +.x_cbp_within_dyad_dev ``` For raw predictors: ```r -.dy_x_dyad_mean_gmc -.dy_x_within_dyad_dev +.x_dyad_mean_gmc +.x_within_dyad_dev ``` Raw longitudinal predictors are decomposed within dyad-time. Raw @@ -163,6 +177,9 @@ partner has an observed value for that component, the dyad mean and deviation are set to missing for that dyad or dyad-time. This preserves APIM-DIM equivalence. +APIM GMC uses all retained non-missing observations, whereas DIM uses complete +pairs. With one-sided missingness, their intercept references can differ. + The current DIM implementation requires one exchangeable dyad composition. Distinguishable dyads and multiple exchangeable compositions should be rejected until role-contrast, composition-specific, or pooling support is explicit. @@ -181,66 +198,73 @@ within dyad-time or within dyad. Directional DSM preparation uses: ```r -model_type = "dsm" +model_types = "dsm" dsm_role_order = c("female", "male") ``` DSM requires exactly one distinguishable composition. The declared role order defines every difference as the first role minus the second and creates -`.dy_dsm_role_contrast` with `+0.5/-0.5` coding. +`.dsm_role_contrast` with `+0.5/-0.5` coding. DIM and DSM share internal dyad-mean and member-deviation calculations. Their public columns then diverge: ```r # Shared mean -.dy_x_dyad_mean_gmc +.x_dyad_mean_gmc # DIM -.dy_x_within_dyad_dev +.x_within_dyad_dev # DSM -.dy_x_within_dyad_diff -.dy_dsm_role_contrast +.x_within_dyad_diff +.dsm_role_contrast ``` For ILD data, DSM creates dyad means and full directional differences for the -raw predictor and separately for `.dy_*_cwp` and `.dy_*_cbp`. Raw and CWP scores +raw predictor and separately for `.{pred}_cwp` and `.{pred}_cbp`. Raw and CWP scores are constructed within dyad-time, while CBP scores are constructed within dyad. Outcome scores are not materialized for the MLM-focused API. Outcomes remain member-level variables selected in the fitted-model formula. +DSM also centers raw dyad means over complete predictor pairs; optional APIM +GMC columns remain APIM-specific. + ## Validation Rules -- `temporal_predictor_decomposition = "time_2l"` requires `time` and `predictors`. -- `lag_predictors` must be a subset of `predictors` and requires a finite, +- `temporal_decomposition = "2l"` requires `time` and `predictors`. +- `add_apim_gmc_predictors = TRUE` requires APIM, resolved temporal + decomposition `"none"`, and at least one numeric predictor. Mixed non-numeric + predictors remain raw and trigger one warning. +- `lag1_predictors` must be a subset of `predictors` and requires a finite, integer-valued numeric `time` index. Values are matched at exactly `time - 1`. -- raw and CWP predictor versions are lagged; stable CBP versions are not. -- predictors used with `temporal_predictor_decomposition = "time_2l"` must be numeric. +- raw, CWP, and requested GMC predictor versions are lagged; stable CBP + versions are not. +- predictors used with `temporal_decomposition = "2l"` must be numeric. - non-numeric predictors can be kept undecomposed with - `temporal_predictor_decomposition = "none"` only for model types that do not + `temporal_decomposition = "none"` only for model types that do not compute dyad means or within-dyad deviations, such as raw APIM. - DIM and DSM predictor construction require numeric predictors. - user data may not contain package-owned `.dy_` columns. - longitudinal raw DIM and DSM predictor construction is available with - `temporal_predictor_decomposition = "none"`; `time_2l` returns raw scores + `temporal_decomposition = "none"`; `"2l"` returns raw scores alongside CWP and CBP scores. -- `temporal_predictor_decomposition` applies only to predictors. -- `model_type = "dim"` requires one exchangeable dyad composition. -- `model_type = "dsm"` requires one distinguishable dyad composition and an +- `temporal_decomposition` applies only to predictors. +- `model_types = "dim"` requires one exchangeable dyad composition. +- `model_types = "dsm"` requires one distinguishable dyad composition and an explicit `dsm_role_order`. - DIM and DSM cannot be requested in the same preparation call. -## Remaining v0.1.0 Work +## Maintenance Constraints and Deferred Work after v0.1.0 - Keep the print header descriptions for DIM and DSM column families explicit but compact. -- Treat `dim_predictors` and `dsm_predictors` metadata as stable for v0.1 unless - review finds a concrete problem. -- Keep `dyad_generated_columns()` internal for v0.1. It is the normalized - table used by `print.dyadMLM_data()` and documentation-facing summaries, not - a public inspection API. +- Continue treating `dim_predictors` and `dsm_predictors` metadata as stable + unless review finds a concrete problem. +- Keep `dyad_generated_columns()` internal unless a concrete need for a public + inspection API emerges. It is the normalized table used by + `print.dyadMLM_data()` and documentation-facing summaries. - Keep normalized generated-column interpretation focused on `temporal_decomposition`, `dyadic_decomposition`, and `column_centering`. Source metadata can still record implementation details such as whether a DIM @@ -253,7 +277,7 @@ member-level variables selected in the fitted-model formula. - Keep the DSM vignette aligned with the implemented directional score columns and exact long-format interaction model. - Analysis-composition controls run before DIM/DSM compatibility checks. - The implemented order is `include_compositions`, then + The implemented order is `keep_compositions`, then `set_exchangeable_compositions`, then `pool_compositions`. DIM continues to require one final exchangeable composition, whereas DSM requires one final distinguishable composition matching `dsm_role_order`. diff --git a/dev/debug-data-preparation.R b/dev/debug-data-preparation.R index a23a0b97..74682305 100644 --- a/dev/debug-data-preparation.R +++ b/dev/debug-data-preparation.R @@ -155,7 +155,7 @@ setup_infer_dyad_compositions_debug <- function( .groups = "drop" ) |> dplyr::mutate( - .dy_composition = .data$.dy_raw_composition, + .composition = .data$.dy_raw_composition, .dy_pool_member = NA_character_ ) diff --git a/dev/dsm.md b/dev/dsm.md index 0bc3b701..74efbfba 100644 --- a/dev/dsm.md +++ b/dev/dsm.md @@ -1,9 +1,10 @@ # Directional Dyadic Score Model **Status:** predictor preparation, validation, metadata, and printing are -complete for the current v0.1 scope. The vignette contains the cross-sectional -long-format model and APIM transformations. Its final review, direct model-level -equivalence tests, and the planned ILD section remain open. +complete for the v0.1.0 scope. The vignette contains the cross-sectional +long-format model, APIM transformations, and a brief ILD extension. An +automated direct score-equation versus long-interaction coefficient and +covariance equivalence test remains a possible follow-up. ## Purpose @@ -19,8 +20,8 @@ The relevant source is: > Models of interdependent individuals versus dyadic processes in relationship > research. *Journal of Social and Personal Relationships, 35*(1), 59-88. -The paper is stored in -`dev/iida-et-al-2017-models-of-interdependent-individuals-versus-dyadic-processes-in-relationship-research.pdf`. +A local ignored copy of the paper is stored in +`dev/References/iida-et-al-2017-models-of-interdependent-individuals-versus-dyadic-processes-in-relationship-research.pdf`. ## What Iida's DSM estimates @@ -231,8 +232,8 @@ The package must generate a signed dyad-level predictor difference. For an order `c("female", "male")`, for example: ```text -.dy_communication_dyad_mean_gmc -.dy_communication_within_dyad_diff +.communication_dyad_mean_gmc +.communication_within_dyad_diff ``` Both values must be repeated on both member rows of a dyad. The difference @@ -242,7 +243,7 @@ This constant column is necessary for the `XDiff -> YLevel` main effect. The existing column ```text -.dy_communication_within_dyad_dev +.communication_within_dyad_dev ``` is not a DSM difference score. It contains `Xi - XLevel`, so its two values are @@ -266,16 +267,16 @@ adding unused outcome transformations to the MLM-focused API. The package needs a DSM-specific contrast such as ```text -.dy_dsm_role_contrast +.dsm_role_contrast ``` with `+0.5` for the first declared role and `-0.5` for the second. Existing -`.dy_diff_{comp}` columns are not suitable: they are arbitrary contrasts for -exchangeable dyads and are currently zero for distinguishable dyads. DSM -direction must instead be stable and substantively interpretable. Their -different scaling is intentional: a `-1/+1` exchangeable contrast makes its -random slope a member deviation, or half-difference, whereas the DSM contrast -makes its random slope the full directional difference. +`.member_contrast_{comp}_arbitrary` columns are not suitable: they are +arbitrary contrasts for exchangeable dyads and are currently zero for +distinguishable dyads. DSM direction must instead be stable and substantively +interpretable. Their different scaling is intentional: a `-1/+1` exchangeable +contrast makes its random slope a member deviation, or half-difference, whereas +the DSM contrast makes its random slope the full directional difference. ## Relation to the DIM and reduced DSM @@ -310,8 +311,8 @@ The clean conceptual division is: ## Why the preliminary separate models are problematic -Fitting the repeated `.dy_*_dyad_mean` and -`.dy_*_within_dyad_dev` columns as two ordinary univariate mixed models is +Fitting the repeated `.{pred}_dyad_mean` and +`.{pred}_within_dyad_dev` columns as two ordinary univariate mixed models is not Iida's full DSM: - the cross-paths are omitted; @@ -374,7 +375,7 @@ would obscure the core implementation. same internal dyad-mean and member-deviation calculations. 3. `dsm_role_order` must contain exactly the two observed roles without duplicates or missing values. -4. `.dy_dsm_role_contrast` is coded `+0.5/-0.5` from the declared order. +4. `.dsm_role_contrast` is coded `+0.5/-0.5` from the declared order. 5. Each predictor receives a dyad level and full signed dyad difference, repeated on both member rows. 6. Outcome variables remain unchanged and are selected in the model formula. @@ -386,13 +387,13 @@ would obscure the core implementation. Generated-column patterns are: ```text -.dy_dsm_role_contrast -.dy_{pred}_dyad_mean_gmc -.dy_{pred}_within_dyad_diff -.dy_{pred}_cwp_dyad_mean -.dy_{pred}_cwp_within_dyad_diff -.dy_{pred}_cbp_dyad_mean -.dy_{pred}_cbp_within_dyad_diff +.dsm_role_contrast +.{pred}_dyad_mean_gmc +.{pred}_within_dyad_diff +.{pred}_cwp_dyad_mean +.{pred}_cwp_within_dyad_diff +.{pred}_cbp_dyad_mean +.{pred}_cbp_within_dyad_diff ``` The exact use of `_gmc` should continue to reflect actual centering. Signed diff --git a/dev/dyadic-ild-current-options.md b/dev/dyadic-ild-current-options.md index c5a49f24..79dba808 100644 --- a/dev/dyadic-ild-current-options.md +++ b/dev/dyadic-ild-current-options.md @@ -92,7 +92,7 @@ restriction shared with the exchangeable model. Let `diff` be the existing stable arbitrary member sign, coded `-1/+1` within each couple (for example, -`.dy_diff_assumed_exchangeable_arbitrary`). Then use the current independent +`.member_contrast_arbitrary`). Then use the current independent mean-and-difference blocks: ```r diff --git a/dev/paper-idea-explaining-interdependence-apim.html b/dev/paper-idea-explaining-interdependence-apim.html deleted file mode 100644 index e2cf5f46..00000000 --- a/dev/paper-idea-explaining-interdependence-apim.html +++ /dev/null @@ -1,2147 +0,0 @@ - - - - - - - - - - - - - - - -Explaining Interdependence in the Actor–Partner Interdependence Model - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - -
-
-
-
-
- -
- - - - - - - -
-

Working claim. An APIM should not only account -for interdependence. It can also explain where the covariance -between partners’ outcomes comes from.

-
-

This document is deliberately both a paper outline and a visual check -of the underlying path tracing. The most important question is whether -the five highlighted routes below reconstruct the combinations Niall -Bolger had in mind.

-
-

1 The idea in one -paragraph

-

The APIM is usually introduced through actor effects, partner -effects, and a residual correlation. That presentation says how -predictors relate to each person’s outcome, but it rarely answers a -natural dyadic question:

-
-

Why are the two partners’ outcomes correlated, and how much of that -interdependence is associated with each modeled route?

-
-

For a single dyadic predictor, standard path tracing gives an exact -additive answer. Outcome covariance can travel through four -predictor-side path pairs: actor–actor, actor–partner, partner–actor, -and partner–partner. A fifth component is the remaining residual -covariance. These five signed quantities sum exactly to the partners’ -outcome covariance. Dividing every component by the same two total -outcome standard deviations makes them sum to the observed outcome -correlation.

-
-
-

2 The complete -one-predictor APIM

-

For distinguishable members 1 and 2, write

-

\[ -Y_1=a_1X_1+p_1X_2+\varepsilon_1, -\]

-

\[ -Y_2=a_2X_2+p_2X_1+\varepsilon_2. -\]

-

Intercepts are omitted because they do not affect variances or -covariances. The subscript on an actor or partner effect identifies the -outcome member: \(p_1\) is the effect of member 2’s predictor -on member 1’s outcome; \(p_2\) is the -effect of member 1’s predictor on member 2’s outcome.

-
-Path diagram with predictors X1 and X2, outcomes Y1 and Y2, blue actor paths, purple crossed partner paths, covariance between predictors, and covariance between outcome residuals. -

-Complete distinguishable APIM used for the decomposition. Blue paths are -actor effects, purple paths are partner effects, the upper double-headed -arrow is predictor covariance, and the lower double-headed arrow is -residual outcome covariance. -

-
-

The outcome covariance is

-

\[ -\begin{aligned} -\operatorname{Cov}(Y_1,Y_2) -={}& -\underbrace{a_1a_2\operatorname{Cov}(X_1,X_2)}_{\text{actor--actor}} -+\underbrace{a_1p_2\operatorname{Var}(X_1)}_{\text{actor--partner}}\\ -&+\underbrace{p_1a_2\operatorname{Var}(X_2)}_{\text{partner--actor}} -+\underbrace{p_1p_2\operatorname{Cov}(X_1,X_2)}_{\text{partner--partner}} -+\underbrace{\operatorname{Cov}(\varepsilon_1,\varepsilon_2)}_{\text{residual}}. -\end{aligned} -\]

-
-
-

3 Visual path tracing: -the likely forgotten combinations

-
-Six small APIM path diagrams. Five panels separately highlight actor-actor, actor-partner, partner-actor, partner-partner, and residual covariance routes. A sixth panel shows their sum. -

-The five covariance-carrying routes in a one-predictor distinguishable -APIM. Pale paths are present in the APIM but do not belong to the -highlighted component. The final panel restores all paths. -

-
-

The four predictor-side combinations form a useful \(2\times2\) table:

- ------ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Path into \(Y_1\)Path into \(Y_2\)Shared predictor quantityContribution
actor \(a_1\)actor \(a_2\)\(\operatorname{Cov}(X_1,X_2)\)\(C_{AA}=a_1a_2\operatorname{Cov}(X_1,X_2)\)
actor \(a_1\)partner \(p_2\)\(\operatorname{Var}(X_1)\)\(C_{AP}=a_1p_2\operatorname{Var}(X_1)\)
partner \(p_1\)actor \(a_2\)\(\operatorname{Var}(X_2)\)\(C_{PA}=p_1a_2\operatorname{Var}(X_2)\)
partner \(p_1\)partner \(p_2\)\(\operatorname{Cov}(X_1,X_2)\)\(C_{PP}=p_1p_2\operatorname{Cov}(X_1,X_2)\)
-

The residual component is

-

\[ -C_R=\operatorname{Cov}(\varepsilon_1,\varepsilon_2). -\]

-

Therefore,

-

\[ -\operatorname{Cov}(Y_1,Y_2) -=C_{AA}+C_{AP}+C_{PA}+C_{PP}+C_R. -\]

-
-

3.1 Plain-language -interpretation

-
    -
  • Actor–actor: partners resemble each other on \(X\), and each person’s own \(X\) predicts their own \(Y\).
  • -
  • Actor–partner: member 1’s \(X\) reaches both outcomes—through an actor -path into \(Y_1\) and a partner path -into \(Y_2\).
  • -
  • Partner–actor: member 2’s \(X\) reaches both outcomes in the analogous -way.
  • -
  • Partner–partner: partners resemble each other on -\(X\), and each predictor crosses to -the other member’s outcome.
  • -
  • Residual: outcome interdependence that remains -after the modeled predictor routes.
  • -
-

This yields two broader substantive families:

-

\[ -\underbrace{C_{AP}+C_{PA}}_{\text{predictor transmission}} -\qquad\text{and}\qquad -\underbrace{C_{AA}+C_{PP}}_{\text{predictor similarity}}. -\]

-

The phrase “actor-driven covariance” by itself is potentially -misleading. One person’s predictor variance creates covariance between -the two outcomes only when that predictor reaches both -outcomes—once through an actor path and once through a partner path. -Actor and partner paths work in pairs.

-
-
-
-

4 From covariance to -correlation points

-

Define

-

\[ -s_Y=\operatorname{SD}(Y_1)\operatorname{SD}(Y_2). -\]

-

For every component \(C_k\), define -a correlation-point contribution

-

\[ -c_k=\frac{C_k}{s_Y}. -\]

-

Because every component uses the same denominator,

-

\[ -\rho_{Y_1Y_2} -=c_{AA}+c_{AP}+c_{PA}+c_{PP}+c_R. -\]

-

The required total outcome variances are

-

\[ -\begin{aligned} -\operatorname{Var}(Y_1) -={}&a_1^2\operatorname{Var}(X_1) -+p_1^2\operatorname{Var}(X_2) -+2a_1p_1\operatorname{Cov}(X_1,X_2) -+\operatorname{Var}(\varepsilon_1),\\ -\operatorname{Var}(Y_2) -={}&a_2^2\operatorname{Var}(X_2) -+p_2^2\operatorname{Var}(X_1) -+2a_2p_2\operatorname{Cov}(X_1,X_2) -+\operatorname{Var}(\varepsilon_2). -\end{aligned} -\]

-
-

Important distinction. The residual correlation -\(\operatorname{Cor}(\varepsilon_1,\varepsilon_2)\) -divides residual covariance by the two residual -standard deviations. The residual contribution \(c_R\) divides the same covariance by the -two total outcome standard deviations. Only \(c_R\) is on the same scale as the other -pieces of the observed outcome correlation.

-
-
-
-

5 Worked numerical -example

-

Suppose

-

\[ -\operatorname{Var}(X_1)=\operatorname{Var}(X_2)=1, -\qquad -\operatorname{Cov}(X_1,X_2)=0.40, -\]

-

\[ -a_1=0.50,\quad a_2=0.40,\quad p_1=0.20,\quad p_2=0.30, -\]

-

and

-

\[ -\boldsymbol\Psi= -\begin{pmatrix} -0.50 & 0.15\\ -0.15 & 0.55 -\end{pmatrix}. -\]

- ----- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
RouteCovariance contributionCorrelation-point contribution
Actor–actor0.0800.091
Actor–partner0.1500.170
Partner–actor0.0800.091
Partner–partner0.0240.027
Residual0.1500.170
-
-Waterfall chart in which actor-actor, actor-partner, partner-actor, partner-partner, and residual correlation contributions accumulate to the total outcome correlation. -

-Waterfall decomposition of the partners’ outcome correlation. Each route -starts where the preceding route ended; the five signed increments -arrive exactly at the total outcome correlation. -

-
-

Here,

-

\[ -\operatorname{Cov}(Y_1,Y_2)=0.484, -\qquad -\rho_{Y_1Y_2}=0.548. -\]

-

The residual correlation is 0.286, but its contribution to the total -outcome correlation is only 0.170. These numbers answer different -questions.

-
-
-

6 Same interdependence, -different explanation

-

The decomposition is useful because the same total partner -correlation can hide very different mechanisms. The second hypothetical -model below is chosen to have the same outcome -variances and covariance as the first model, but stronger actor paths, -weaker partner paths, and more residual covariance.

-
-Two horizontal stacked bars of identical total length. Scenario A has larger actor-partner and partner-actor sections; scenario B has larger actor-actor and residual sections. -

-Two APIMs with the same total outcome correlation but different sources -of interdependence. Each horizontal stack has exactly the same length. -

-
-

This is the paper’s most intuitive motivation: reporting only the -total or residual correlation cannot distinguish these explanations.

-
-
-

7 Exchangeable APIM

-

For exchangeable dyads, impose

-

\[ -a_1=a_2=a, -\qquad -p_1=p_2=p, -\]

-

\[ -\operatorname{Var}(X_1)=\operatorname{Var}(X_2)=\sigma_X^2, -\qquad -\operatorname{Cov}(X_1,X_2)=\sigma_{X12}. -\]

-

The same decomposition becomes

-

\[ -\operatorname{Cov}(Y_1,Y_2) -=2ap\sigma_X^2 -+(a^2+p^2)\sigma_{X12} -+\sigma_{\varepsilon12}. -\]

-

Equivalently, keep all four labels to make the path-tracing -correspondence visible:

-

\[ -\underbrace{a^2\sigma_{X12}}_{AA} -+\underbrace{ap\sigma_X^2}_{AP} -+\underbrace{pa\sigma_X^2}_{PA} -+\underbrace{p^2\sigma_{X12}}_{PP} -+\underbrace{\sigma_{\varepsilon12}}_{R}. -\]

-

Exchangeability therefore pools pairs of components; it does not -remove the logic of the decomposition.

-
-
-

8 Matrix form and -extension to several predictors

-

Let

-

\[ -\mathbf Y=\mathbf B\mathbf X+\boldsymbol\varepsilon, -\]

-

with predictor covariance matrix \(\boldsymbol\Sigma_X\) and residual -covariance matrix \(\boldsymbol\Psi\). -Then

-

\[ -\boldsymbol\Sigma_Y -=\mathbf B\boldsymbol\Sigma_X\mathbf B^\mathsf{T} -+\boldsymbol\Psi. -\]

-

For the covariance between the two outcomes,

-

\[ -\operatorname{Cov}(Y_1,Y_2) -=\sum_r\sum_s B_{1r}\Sigma_{X,rs}B_{2s}+\Psi_{12}. -\]

-

This is the complete generalization: every contribution is one -coefficient into \(Y_1\), one predictor -variance or covariance, and one coefficient into \(Y_2\).

-

However, several predictors introduce cross-predictor covariance -terms. Their allocation to a named construct may depend on how -predictors are grouped or parameterized. The first paper should -therefore make the single dyadic predictor pair the transparent core -result, then present the matrix expression and a prespecified grouping -rule as the extension.

-
-
-

9 Proposed paper -contribution

-
-

9.1 Central -contribution

-

Reframe dyadic interdependence from a nuisance that must be -accommodated into an outcome that can be descriptively decomposed and -explained.

-
-
-

9.2 Concrete -contributions

-
    -
  1. Derive the exact five-part covariance decomposition for a -distinguishable APIM.
  2. -
  3. Show the simplified exchangeable form.
  4. -
  5. Separate predictor transmission from -predictor similarity.
  6. -
  7. Translate covariance components into signed correlation-point -contributions that sum to the partners’ outcome correlation.
  8. -
  9. Clarify why residual correlation is not the unexplained share of the -total outcome correlation.
  10. -
  11. Show cancellation and suppression: components can have opposing -signs even when total interdependence is small.
  12. -
  13. Provide uncertainty intervals, preferably by bootstrapping dyads and -recomputing the complete decomposition.
  14. -
  15. Provide software that extracts fitted coefficients, predictor -moments, and residual covariance and produces a table plus a path or -waterfall plot.
  16. -
  17. Demonstrate that dyads can have the same total correlation but very -different mechanisms.
  18. -
-

The claims should remain descriptive unless the design and -identification support causal language. “Explained” here means -model-implied statistical attribution, not necessarily causal mediation -or interpersonal influence.

-
-
-

9.3 Novelty boundary

-

The path-tracing identity itself is standard covariance algebra and -should not be presented as a newly discovered formula. APIM teaching -material already shows versions of the standardized expression, and -earlier dyadic work by Bolger and Shrout explicitly treats observed -dyadic covariance as something that may arise from interpersonal -influence or common events.

-

The potentially publishable contribution is the complete package -around that identity:

-
    -
  • treating total outcome interdependence as the estimand to be -explained;
  • -
  • naming and interpreting all four predictor-side routes;
  • -
  • separating predictor transmission from predictor similarity;
  • -
  • putting every route on one additive correlation-point scale;
  • -
  • providing uncertainty, visualizations, and reproducible -software;
  • -
  • showing empirically that the same total interdependence can have -different explanations.
  • -
-

This boundary should be checked in a focused literature review before -making a novelty claim.

-
-
-
-

10 Proposed studies

-
-

10.1 Study 1: derivation -and visual explanation

-
    -
  • Begin with the one-predictor distinguishable APIM.
  • -
  • Derive the five components by direct covariance algebra and by path -tracing.
  • -
  • Show the exchangeable special case.
  • -
  • Distinguish covariance, correlation points, residual covariance, and -residual correlation.
  • -
-
-
-

10.2 Study 2: -simulation

-

Vary:

-
    -
  • predictor correlation;
  • -
  • actor and partner path signs and magnitudes;
  • -
  • residual covariance;
  • -
  • distinguishable versus exchangeable coefficients;
  • -
  • sample size and unequal predictor variances.
  • -
-

Evaluate:

-
    -
  • recovery of each component;
  • -
  • bootstrap interval coverage;
  • -
  • cancellation when positive and negative components coexist;
  • -
  • stability of proportions when total covariance is close to -zero.
  • -
-

The primary estimands should be signed covariance or -correlation-point contributions. Percentages should be secondary because -signed percentages can be negative or exceed 100% when components -cancel, and become unstable when the total is near zero.

-
-
-

10.3 Study 3: empirical -demonstration

-

Use one substantively clear dyadic predictor and outcome. Report:

-
    -
  1. the raw partner outcome covariance and correlation;
  2. -
  3. all four predictor-side components;
  4. -
  5. their transmission and similarity groupings;
  6. -
  7. the residual component;
  8. -
  9. dyad-bootstrap uncertainty intervals;
  10. -
  11. a path diagram and signed waterfall plot.
  12. -
-

A compelling example would compare two outcomes or subgroups with -similar total interdependence but different decompositions.

-
-
-
-

11 Relationship to model -fitting

-

In an SEM, predictor variances and covariances can be estimated -jointly with the APIM. In the multilevel implementation used by -dyadMLM, predictors are usually conditioned on rather than -jointly modeled. The decomposition can still use their empirical -dyad-level variance–covariance matrix. A dyad bootstrap should then -refit the APIM and recompute predictor moments in each -bootstrap sample, carrying both sources of uncertainty forward.

-

For an intercept-only model, all outcome covariance is residual -covariance. In the predictor model,

-

\[ -\operatorname{Cov}(Y_1,Y_2)-\Psi_{12} -=C_{AA}+C_{AP}+C_{PA}+C_{PP}. -\]

-

Thus, under the same sample, scale, and residual specification, the -reduction from the intercept-only residual covariance can be connected -exactly to the sum of the predictor-side routes.

-
-
-

12 Proposed paper -structure

-
    -
  1. The missing question: APIMs model interdependence, -but rarely explain its composition.
  2. -
  3. One picture, five routes: introduce the visual path -tracing.
  4. -
  5. Exact decomposition: covariance algebra and -correlation points.
  6. -
  7. Exchangeable dyads: show the pooled special -case.
  8. -
  9. Inference: dyad bootstrap and reporting -recommendations.
  10. -
  11. Simulation: recovery, cancellation, and -uncertainty.
  12. -
  13. Empirical example: same total interdependence, -interpretable sources.
  14. -
  15. Extensions and limits: several predictors, -longitudinal APIMs, and causal caution.
  16. -
-
-
-

13 Candidate titles

-

Preferred

-
-

Explaining Interdependence in the Actor–Partner Interdependence -Model:
-Decomposing Dyadic Outcome Covariance

-
-

Alternatives:

-
    -
  • Where Does Dyadic Interdependence Come From? A Covariance -Decomposition for the APIM
  • -
  • Beyond the Residual Correlation: Explaining Interdependence in -the APIM
  • -
  • From Actor and Partner Paths to Dyadic Interdependence
  • -
  • Partitioning Interdependence in the Actor–Partner -Interdependence Model
  • -
-
-
-

14 What to verify with -Niall

-

The one-predictor decomposition is algebraically complete. The part -that needs historical and conceptual confirmation is whether Niall’s -intended paper was exactly this decomposition or a broader version. A -concise check would be:

-
-

I reconstructed five sources of APIM outcome covariance: actor–actor -and partner–partner paths carried by predictor covariance; actor–partner -and partner–actor paths carried by each member’s predictor variance; and -residual covariance. I then place all five on the outcome-correlation -scale so they sum exactly to total interdependence. Is this the set of -combinations you had in mind, or were you also thinking about multiple -predictors or longitudinal paths?

-
-

Further points to ask:

-
    -
  • Did he intend the four individual components or primarily the two -grouped mechanisms, transmission and similarity?
  • -
  • Was the goal decomposition of covariance, standardized correlation, -or the reduction in residual covariance after predictors enter?
  • -
  • Did he have a preferred empirical example?
  • -
  • Does he know an earlier derivation that should be treated as the -starting point rather than as a novel result?
  • -
-
-
-

15 Immediate next -steps

-
    -
  1. Show Niall the five-panel path figure and the paragraph above.
  2. -
  3. Confirm intellectual provenance and the intended scope.
  4. -
  5. Run a focused literature search on APIM covariance decomposition and -explained interdependence.
  6. -
  7. Prototype a small internal R function that returns the five -components from coefficients, predictor moments, and \(\boldsymbol\Psi\).
  8. -
  9. Test the decomposition on the workshop APIM example before -committing to a full simulation study.
  10. -
-
- - - -
-
- -
- - - - - - - - - - - - - - - - diff --git a/dev/roadmap.md b/dev/roadmap.md index a55410ec..c89f7bdb 100644 --- a/dev/roadmap.md +++ b/dev/roadmap.md @@ -12,16 +12,16 @@ helpers, and eventually model syntax explicit and reproducible. - Temporal predictor decomposition and predictor-shape planning: [`centering.md`](centering.md) -- Possible future reintroduction of inspection-only incomplete/unknown dyads: - [`keep-behavior-notes.md`](keep-behavior-notes.md) +- Inspection-only incomplete/unknown dyads remain intentionally unsupported; + revisit that boundary only for a concrete user-facing need. - Long-term custom Stan / dyadic residual VAR planning: [`stan.md`](stan.md) - the note is provisional and must be revised against the methodological papers in [`References/`](References/) before implementation - Directional DSM derivation and implementation record: [`dsm.md`](dsm.md) -- Initial covariance back-transformation mathematics and design history: +- Covariance back-transformation mathematics and design history: [`backtransform.md`](backtransform.md) - - its original API scope and implementation-status sections are stale; use - the current-state section below and the code as authoritative + - use the current code, generated documentation, and tests as authoritative + for exact API behavior - ILD non-independence evidence and tutorial policy: [`ild-nonindependence.md`](ild-nonindependence.md) - Data-preparation debugging scratch helpers: @@ -29,10 +29,10 @@ helpers, and eventually model syntax explicit and reproducible. ## Current State -The package is currently in final preparation for its first CRAN release. The -core data-preparation API is implemented and covered by tests, the README links -to the pkgdown site, and GitHub Actions are configured for R CMD check and -pkgdown publishing. +Version 0.1.0 has been accepted by CRAN and tagged as `v0.1.0`. Development now +continues as version 0.1.0.9000. The core data-preparation API is implemented +and covered by tests, the README links to the pkgdown site, and GitHub Actions +are configured for R CMD check and pkgdown publishing. Recently completed cleanup: @@ -70,11 +70,13 @@ Recently completed cleanup: products, and fitted-row coding validation when the indicator columns remain available -Immediate sequence: +Immediate post-release sequence: -1. synchronize the 0.1.0 release metadata and reserved Zenodo concept DOI -2. rerun the complete source-package, vignette, and pkgdown checks -3. submit to CRAN after final review and explicit approval +1. create the GitHub Release from the accepted `v0.1.0` tag +2. upload the exact accepted source archive to the prepared Zenodo draft, + verify its metadata and checksum, and publish it +3. complete the post-release documentation and workshop cleanup, then verify + the pkgdown and stable workshop URLs after deployment from `main` The engine-independent covariance-array back-transformation and final named `varcov`/`sdcor` results are implemented for `glmmTMB` point estimates and @@ -105,7 +107,7 @@ Target vignette structure: - distinguishable and exchangeable APIMs - within-person and between-person actor/partner effects - generalized outcomes, including negative-binomial examples - - `.dy_is_*`, `.dy_member_contrast_*`, and raw actor/partner predictor columns + - `.is_*`, `.member_contrast_*`, and raw actor/partner predictor columns - a brief comparison of manifest raw outcome lags and separately estimated within-/between-person outcome-lag components, with their different interpretations and small-T cautions @@ -129,15 +131,17 @@ Target vignette structure: - a brief ILD extension - outcomes remain unchanged in the MLM-focused preparation API -## Version 0.1.0 - First CRAN Release Candidate +## Version 0.1.0 - Accepted CRAN Release Goal: ship a small, reliable data-preparation and interpretation workflow with enough ILD support to be useful for composition-aware dyadic MLMs before adding larger model-building features. -### v0.1.0 Release Gate +### v0.1.0 Release Record and Follow-up -The first release milestone is complete when all of the following are true: +Version 0.1.0 was accepted by CRAN and tagged. Completed items below record the +accepted scope; unchecked items are post-release documentation or maintenance +follow-up rather than claims about the CRAN release state. - [x] Core composition-aware validation and APIM, DIM, and DSM column construction are implemented and tested. @@ -145,7 +149,7 @@ The first release milestone is complete when all of the following are true: filtering, exchangeability overrides, pooling, metadata, and printing are implemented and tested for the documented scope. - [x] `recover_exchangeable_covariance()` converts fitted - shared/`.dy_member_contrast_*` random-effect + shared/`.member_contrast_*` random-effect structures to interpretable member-level covariance matrices. Backend extraction and matching are implemented for `glmmTMB` and single-response `brms`, including draw-wise transformation, constrained components, final @@ -159,7 +163,9 @@ The first release milestone is complete when all of the following are true: example data or explicitly presented as advanced/diagnostic specifications. - [ ] Documentation, README, citation metadata, pkgdown, tests, and multi-platform R CMD checks are clean. -- [ ] Version `0.1.0` is released, tagged, and archived. +- [x] Version `0.1.0` is released on CRAN and tagged as `v0.1.0`. +- [ ] Create the GitHub Release and publish the exact accepted source archive + through the prepared Zenodo record. Not required for v0.1.0: model fitting or syntax-generation wrappers, public fitted-diagram functions, automated AR(1)/VAR diagnostics, a universal @@ -211,8 +217,8 @@ Detailed implemented scope and final checks follow. 3. apply `set_exchangeable_compositions` 4. apply `pool_compositions` only to compositions that are exchangeable after step 3 - 5. build `.dy_composition`, `.dy_composition_role`, `.dy_is_*`, - `.dy_member_contrast_*`, + 5. build `.composition`, `.composition_role`, `.is_*`, + `.member_contrast_*`, print summaries, and metadata from the final analysis compositions - Do not generate an additional raw-composition column. Preserve any user-supplied columns, and record pooling provenance in @@ -221,8 +227,8 @@ Detailed implemented scope and final checks follow. definitions, or pooling requests that include non-exchangeable compositions - Handle incomplete dyads and missing roles with explicit `error` and `drop` behavior -- Return factor columns for `.dy_composition` and - `.dy_composition_role` +- Return factor columns for `.composition` and + `.composition_role` - Add temporal predictor decomposition and predictor-shape helpers for ILD data - Keep the implemented `"2l"` workflow described in [`centering.md`](centering.md) - Keep APIM, DIM, and DSM on the same temporal predictor decomposition @@ -242,7 +248,7 @@ Detailed implemented scope and final checks follow. from the shared metadata - decompose raw longitudinal DIM/DSM predictors within dyad-occasion, while retaining dyad-level construction for CBP components - - keep the established `.dy_{pred}_actor` and `.dy_{pred}_partner` names; do + - keep the established `.{pred}_actor` and `.{pred}_partner` names; do not reintroduce `_raw_` into generated column names - document that raw and decomposed versions of the same contemporaneous predictor should not all be included in one formula because they are @@ -269,8 +275,8 @@ Detailed implemented scope and final checks follow. - Show structural columns: dyad, member, optional role, optional time - Show dyad compositions with composition name, dyad type, and dyad count - Show generated column families and one-line meanings: - `.dy_composition`, `.dy_composition_role`, `.dy_is_*`, - `.dy_member_contrast_*`, + `.composition`, `.composition_role`, `.is_*`, + `.member_contrast_*`, temporal predictor components, APIM predictor columns, DIM deviations, and DSM directional predictor columns - Drive generated-column printing from `dyad_generated_columns()`, which @@ -289,51 +295,51 @@ Detailed implemented scope and final checks follow. # male_x_male exchangeable 120 dyads # # Added columns: - # .dy_composition inferred dyad composition - # .dy_composition_role composition-specific member role - # .dy_is_{comp-role} composition-role indicator columns - # .dy_member_contrast_{comp}_arbitrary + # .composition inferred dyad composition + # .composition_role composition-specific member role + # .is_{comp-role} composition-role indicator columns + # .member_contrast_{comp}_arbitrary # composition-specific member contrasts # with arbitrary direction; 0 for # distinguishable dyads or other # exchangeable compositions - # .dy_{pred}_cwp within-person predictor: momentary + # .{pred}_cwp within-person predictor: momentary # deviations from each person's usual level - # .dy_{pred}_cbp between-person predictor: stable + # .{pred}_cbp between-person predictor: stable # differences from the average person's usual # level - # .dy_{pred}_actor APIM actor predictor: actor's original values - # .dy_{pred}_partner APIM partner predictor: partner's original values - # .dy_{pred}_cwp_actor APIM within-person actor predictor: actor's + # .{pred}_actor APIM actor predictor: actor's original values + # .{pred}_partner APIM partner predictor: partner's original values + # .{pred}_cwp_actor APIM within-person actor predictor: actor's # momentary deviations from their usual level - # .dy_{pred}_cwp_partner APIM within-person partner predictor: + # .{pred}_cwp_partner APIM within-person partner predictor: # partner's momentary deviations from their # usual level - # .dy_{pred}_cbp_actor APIM between-person actor predictor: + # .{pred}_cbp_actor APIM between-person actor predictor: # actor's stable difference from the average # person's usual level - # .dy_{pred}_cbp_partner APIM between-person partner predictor: + # .{pred}_cbp_partner APIM between-person partner predictor: # partner's stable difference from the # average person's usual level - # .dy_{pred}_dyad_mean_gmc raw dyad-mean predictor, grand-mean centered - # .dy_{pred}_within_dyad_dev DIM raw within-dyad predictor deviation - # .dy_{pred}_within_dyad_diff DSM raw signed predictor difference - # .dy_{pred}_cwp_dyad_mean within-person dyad-mean predictor: + # .{pred}_dyad_mean_gmc raw dyad-mean predictor, grand-mean centered + # .{pred}_within_dyad_dev DIM raw within-dyad predictor deviation + # .{pred}_within_dyad_diff DSM raw signed predictor difference + # .{pred}_cwp_dyad_mean within-person dyad-mean predictor: # shared momentary deviations in the dyad - # .dy_{pred}_cwp_within_dyad_dev + # .{pred}_cwp_within_dyad_dev # DIM within-person within-dyad predictor # deviation: person's momentary deviation # from the dyad average - # .dy_{pred}_cbp_dyad_mean between-person dyad-mean predictor: + # .{pred}_cbp_dyad_mean between-person dyad-mean predictor: # dyad's stable usual level, grand-mean # centered - # .dy_{pred}_cbp_within_dyad_dev + # .{pred}_cbp_within_dyad_dev # DIM between-person within-dyad predictor # deviation: person's stable difference from # the dyad's usual level - # .dy_dsm_role_contrast DSM +0.5/-0.5 directional role contrast - # .dy_{pred}_cwp_within_dyad_diff DSM within-person signed predictor difference - # .dy_{pred}_cbp_within_dyad_diff DSM between-person signed predictor difference + # .dsm_role_contrast DSM +0.5/-0.5 directional role contrast + # .{pred}_cwp_within_dyad_diff DSM within-person signed predictor difference + # .{pred}_cbp_within_dyad_diff DSM between-person signed predictor difference # # A tibble: 10,080 x 23 personID coupleID diaryday gender dyad_composition closeness provided_support ... @@ -365,9 +371,10 @@ Detailed implemented scope and final checks follow. - `inst/CITATION` for R users - `CITATION.cff` for GitHub and future Zenodo metadata -### Pre-CRAN v0.1.0 Checklist +### v0.1.0 Implementation Record and Follow-up Checklist -Complete these before calling the feature set CRAN-ready: +This section preserves the implementation record used for the first release. +Remaining unchecked or imperative items are follow-up maintenance work. - Rebuild and inspect generated documentation - run `devtools::document()` @@ -433,7 +440,8 @@ Complete these before calling the feature set CRAN-ready: - in `apim.Rmd`, show concise versions of both the manifest raw-lag and manifest within-between lag specifications; describe them as different parameterizations rather than interchangeable corrections - - complete the planned ILD DSM section and final review of `dsm.Rmd` + - keep the completed ILD DSM section aligned with the implemented API and + complete any remaining review of `dsm.Rmd` - keep heavy or convergence-sensitive examples out of `getting-started.Rmd` and mark advanced examples `eval = FALSE` where needed - Keep the completed DIM vignette stable @@ -544,19 +552,18 @@ Complete these before calling the feature set CRAN-ready: - inspect README, vignette, examples, `inst/CITATION`, and package metadata for CRAN-facing clarity -- Release to CRAN once checks, tests, docs, README, and vignette are clean - - Keep Zenodo draft `21481721` for 0.1.0 unpublished during CRAN review; - its reserved version DOI is `10.5281/zenodo.21481721` - - Submit source package to CRAN without requiring a Git tag first - - After CRAN acceptance, tag the accepted commit as `v0.1.0` - - Create a GitHub release from that tag - - Upload the exact accepted source archive to the prepared Zenodo draft - - Verify the draft metadata and checksum, then publish it +- Complete release archiving after CRAN acceptance + - [x] Submit the source package to CRAN and obtain acceptance + - [x] Tag the accepted commit as `v0.1.0` + - [ ] Create a GitHub Release from that tag + - [ ] Upload the exact accepted source archive to Zenodo draft `21481721`, + whose reserved version DOI is `10.5281/zenodo.21481721` + - [ ] Verify the Zenodo metadata and checksum, then publish it - Continue to use the concept DOI in package-level citation metadata ## Near-term maintenance after 0.1.0 -- Extend `compare_dyad_models()` to support fitted `brms` models, using a +- Extend `compare_nested_models()` to support fitted `brms` models, using a Bayesian-appropriate comparison method and similarly clear output. ## Post-0.1.0 method development @@ -682,7 +689,7 @@ Minimum expected state: - clear metadata for raw observed compositions versus final analysis compositions - complete getting-started, APIM, mixed-APIM, DIM, and DSM documentation paths -- interpretation helpers for `.dy_member_contrast_*` structures +- interpretation helpers for `.member_contrast_*` structures - syntax generation for at least one primary model engine, preferably `glmmTMB`, with tests that protect intended estimands - CRAN release history and pkgdown documentation that match the current API @@ -702,7 +709,7 @@ Target state before JOSS submission: package - Robust temporal predictor decomposition for ILD data - Composition filtering, exchangeability, and pooling helpers -- `.dy_member_contrast_*` interpretation helpers +- `.member_contrast_*` interpretation helpers - Formula or syntax generation for at least `glmmTMB`; a second modeling backend is optional and is not a JOSS submission gate - Reproducible vignettes showing composition-aware dyadic MLM workflows diff --git a/dev/vignettes/exchangeable-location-scale-dim-apim.Rmd b/dev/vignettes/exchangeable-location-scale-dim-apim.Rmd index db32d6f8..afb2f794 100644 --- a/dev/vignettes/exchangeable-location-scale-dim-apim.Rmd +++ b/dev/vignettes/exchangeable-location-scale-dim-apim.Rmd @@ -1200,7 +1200,7 @@ $\operatorname{Cov}(r_{\mathrm{M}},r_{\mathrm{D}})=0$, the expanded exchangeable covariance matrix is $$ -\boldsymbol{\Sigma}_{\mathrm{e}} +\Sigma_{\mathrm{e}} = \begin{pmatrix} v_{\mathrm{M}}+v_{\mathrm{D}} & v_{\mathrm{M}}-v_{\mathrm{D}}\\ @@ -1231,7 +1231,7 @@ A conventional Gaussian exchangeable APIM with one constant covariance matrix can match the extended model's **marginal** covariance matrix, $$ -\boldsymbol{\Sigma}_{\mathrm{e}} +\Sigma_{\mathrm{e}} = \begin{pmatrix} \sigma_{\mathrm{M}}^2+\bar v_{\mathrm{D}} & \sigma_{\mathrm{M}}^2-\bar v_{\mathrm{D}}\\ @@ -1396,7 +1396,7 @@ $r_{\mathrm{D}}\mid z_X\sim\mathcal{N}(0,v_{\mathrm{D}}(z_X))$, and the two comp conditionally independent. The member-level conditional covariance matrix is $$ -\boldsymbol{\Sigma}_{\mathrm{e}}(z_X) +\Sigma_{\mathrm{e}}(z_X) = \begin{pmatrix} v_{\mathrm{M}}+v_{\mathrm{D}}(z_X) & v_{\mathrm{M}}-v_{\mathrm{D}}(z_X)\\ diff --git a/dev/vignettes/generalized-apim.Rmd b/dev/vignettes/generalized-apim.Rmd index 68b77cde..9d4a00e6 100644 --- a/dev/vignettes/generalized-apim.Rmd +++ b/dev/vignettes/generalized-apim.Rmd @@ -44,6 +44,10 @@ because the dyadic structure is unchanged. The interpretation of the fitted model differs: fixed and random effects act on the log-mean scale, while the observation-level negative-binomial variance remains part of the model. +These examples use `add_apim_gmc_predictors = TRUE`, which retains raw APIM +columns and adds stress variants centered over all retained non-missing values. +Using raw columns instead changes only the intercept reference. + ### Distinguishable negative-binomial APIM ```{r prepare-nbinom-distinguishable} @@ -53,6 +57,7 @@ nbinom_distinguishable_data <- dyadMLM::prepare_dyad_data( member = personID, role = gender, predictors = stress, + add_apim_gmc_predictors = TRUE, # All three observed compositions in `dyads_nbinom_cross` are detected and # retained by default. This example focuses on `female-male` dyads, so we # restrict the analysis here. @@ -69,16 +74,16 @@ summary(nbinom_distinguishable_data) nbinom_distinguishable_model <- glmmTMB::glmmTMB( conflict_count ~ 0 + # Role-specific intercepts - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + + .is_female + + .is_male + # Role-specific actor effects of stress - .dy_is_female_x_male_female:.dy_stress_actor + - .dy_is_female_x_male_male:.dy_stress_actor + + .is_female:.stress_gmc_actor + + .is_male:.stress_gmc_actor + # Role-specific partner effects of stress - .dy_is_female_x_male_female:.dy_stress_partner + - .dy_is_female_x_male_male:.dy_stress_partner + + .is_female:.stress_gmc_partner + + .is_male:.stress_gmc_partner + # Shared latent dyad effect for stable non-independence (1 | coupleID), @@ -106,6 +111,7 @@ nbinom_exchangeable_data <- dyadMLM::prepare_dyad_data( member = personID, role = gender, predictors = stress, + add_apim_gmc_predictors = TRUE, keep_compositions = "male-male", seed = 123 ) @@ -119,12 +125,12 @@ nbinom_exchangeable_model <- glmmTMB::glmmTMB( conflict_count ~ # Pooled intercept and actor and partner effects 1 + - .dy_stress_actor + - .dy_stress_partner + + .stress_gmc_actor + + .stress_gmc_partner + # Exchangeable latent dyad covariance on the log-mean scale (1 | coupleID) + - (0 + .dy_member_contrast_male_x_male_arbitrary | coupleID), + (0 + .member_contrast_arbitrary | coupleID), family = glmmTMB::nbinom2(link = "log"), data = nbinom_exchangeable_data ) diff --git a/dev/vignettes/mixed-apim.Rmd b/dev/vignettes/mixed-apim.Rmd index 5c09f051..74b92861 100644 --- a/dev/vignettes/mixed-apim.Rmd +++ b/dev/vignettes/mixed-apim.Rmd @@ -82,7 +82,7 @@ parameterization. This gives the two members equal variances while allowing their within-dyad covariance to be estimated [@delrosarioPracticalGuideSpecifying2025]. -The returned `.dy_member_contrast_*` variables contain `-1` and `1` for the corresponding +The returned `.member_contrast_*` variables contain `-1` and `1` for the corresponding exchangeable composition and `0` for all other compositions. `dyadMLM::prepare_dyad_data()` creates this structure automatically. The [APIM vignette](apim.html#exchangeable-residual-structure) derives @@ -105,25 +105,25 @@ mixed_cross_gaussian_model <- glmmTMB::glmmTMB( ##### INTERCEPTS ###### # fixed intercepts for individuals from distinguishable female-male couples - .dy_is_female_x_male_female + .dy_is_female_x_male_male + + .is_female_x_male_female + .is_female_x_male_male + # fixed pooled intercept for female-female couples - .dy_is_female_x_female + + .is_female_x_female + # fixed pooled intercept for male-male couples - .dy_is_male_x_male + + .is_male_x_male + ##### RESIDUAL STRUCTURE ###### # distinguishable female-male residual covariance - us(0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | coupleID) + + us(0 + .is_female_x_male_female + .is_female_x_male_male | coupleID) + # exchangeable female-female residual covariance via sum-diff - us(0 + .dy_is_female_x_female | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID) + + us(0 + .is_female_x_female | coupleID) + + us(0 + .member_contrast_female_x_female_arbitrary | coupleID) + # exchangeable male-male residual covariance via sum-diff - us(0 + .dy_is_male_x_male | coupleID) + - us(0 + .dy_member_contrast_male_x_male_arbitrary | coupleID) + us(0 + .is_male_x_male | coupleID) + + us(0 + .member_contrast_male_x_male_arbitrary | coupleID) , dispformula = ~ 0 , family = gaussian() @@ -172,7 +172,7 @@ draw_mixed_apim_diagram(model = mixed_cross_gaussian_model) ``` The four fixed-effect indicators are mutually exclusive. With $I$ denoting the -generated `.dy_is_{composition_role}` indicator and $b_0$ a fixed intercept, the +generated `.is_{composition_role}` indicator and $b_0$ a fixed intercept, the fixed part of the full model can be written as: $$ @@ -237,7 +237,7 @@ side. # Test whether male-male and female-female pooled intercepts are different marginaleffects::hypotheses( mixed_cross_gaussian_model, - hypothesis = "conditional_.dy_is_male_x_male = conditional_.dy_is_female_x_female", + hypothesis = "conditional_.is_male_x_male = conditional_.is_female_x_female", re.form = NA ) @@ -245,7 +245,7 @@ marginaleffects::hypotheses( # male-male intercept marginaleffects::hypotheses( mixed_cross_gaussian_model, - hypothesis = "(conditional_.dy_is_female_x_male_female + conditional_.dy_is_female_x_male_male) / 2 = conditional_.dy_is_male_x_male", + hypothesis = "(conditional_.is_female_x_male_female + conditional_.is_female_x_male_male) / 2 = conditional_.is_male_x_male", re.form = NA ) @@ -253,7 +253,7 @@ marginaleffects::hypotheses( # the pooled male intercept from a male-male couple marginaleffects::hypotheses( mixed_cross_gaussian_model, - hypothesis = "conditional_.dy_is_female_x_male_male = conditional_.dy_is_male_x_male", + hypothesis = "conditional_.is_female_x_male_male = conditional_.is_male_x_male", re.form = NA ) @@ -275,7 +275,7 @@ different versions of pooling can be compared. For example, it can be tested whether pooling male-male and female-female couples as same-sex substantially worsens model fit, considering both the fixed effects and random-effects structure. Such model comparisons, performed with -[`dyadMLM::compare_nested_glmmTMB_models()`](https://pascal-kueng.github.io/dyadMLM/reference/compare_nested_glmmTMB_models.html) as +`dyadMLM::compare_nested_models()` as demonstrated in [Testing distinguishability in the APIM vignette](apim.html#testing-distinguishability), require the restricted and unrestricted models to use the same observations and require the restricted model to be nested within the unrestricted model. @@ -287,7 +287,7 @@ plus composition deviations. ### Model comparison with a restricted model The [regular APIM vignette](apim.html#testing-distinguishability) introduces -[`dyadMLM::compare_nested_glmmTMB_models()`](https://pascal-kueng.github.io/dyadMLM/reference/compare_nested_glmmTMB_models.html) by +`dyadMLM::compare_nested_models()` by comparing a distinguishable APIM with its exchangeable restriction. Here, we use the same approach for a mixed-composition constraint. We treat female-male dyads as exchangeable and @@ -310,23 +310,23 @@ mixed_cross_data_constrained <- dyadMLM::prepare_dyad_data( mixed_cross_gaussian_model_constrained <- glmmTMB::glmmTMB( closeness ~ 0 + - .dy_is_female_x_female + - .dy_is_non_female_x_female + + .is_female_x_female + + .is_non_female_x_female + # exchangeable female-female residual covariance via sum-diff - us(0 + .dy_is_female_x_female | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID) + + us(0 + .is_female_x_female | coupleID) + + us(0 + .member_contrast_female_x_female_arbitrary | coupleID) + # pooled female-male and male-male residual covariance via sum-diff - us(0 + .dy_is_non_female_x_female | coupleID) + - us(0 + .dy_member_contrast_non_female_x_female_arbitrary | coupleID) + us(0 + .is_non_female_x_female | coupleID) + + us(0 + .member_contrast_non_female_x_female_arbitrary | coupleID) , dispformula = ~ 0 , family = gaussian() , data = mixed_cross_data_constrained ) -dyadMLM::compare_nested_glmmTMB_models( +dyadMLM::compare_nested_models( mixed_cross_gaussian_model_constrained, mixed_cross_gaussian_model ) @@ -394,51 +394,51 @@ mixed_ild_gaussian_model <- glmmTMB::glmmTMB( closeness ~ 0 + # Composition-specific intercepts - .dy_is_female_x_male_female + .dy_is_female_x_male_male + + .is_female_x_male_female + .is_female_x_male_male + - .dy_is_same_sex + + .is_same_sex + # Composition-specific time trends - .dy_is_female_x_male_female:diaryday + - .dy_is_female_x_male_male:diaryday + + .is_female_x_male_female:diaryday + + .is_female_x_male_male:diaryday + - .dy_is_same_sex:diaryday + + .is_same_sex:diaryday + # Composition-specific within-person actor effects - .dy_is_female_x_male_female:.dy_provided_support_cwp_actor + - .dy_is_female_x_male_male:.dy_provided_support_cwp_actor + + .is_female_x_male_female:.provided_support_cwp_actor + + .is_female_x_male_male:.provided_support_cwp_actor + - .dy_is_same_sex:.dy_provided_support_cwp_actor + + .is_same_sex:.provided_support_cwp_actor + # Composition-specific within-person partner effects - .dy_is_female_x_male_female:.dy_provided_support_cwp_partner + - .dy_is_female_x_male_male:.dy_provided_support_cwp_partner + + .is_female_x_male_female:.provided_support_cwp_partner + + .is_female_x_male_male:.provided_support_cwp_partner + - .dy_is_same_sex:.dy_provided_support_cwp_partner + + .is_same_sex:.provided_support_cwp_partner + # Composition-specific between-person actor effects - .dy_is_female_x_male_female:.dy_provided_support_cbp_actor + - .dy_is_female_x_male_male:.dy_provided_support_cbp_actor + + .is_female_x_male_female:.provided_support_cbp_actor + + .is_female_x_male_male:.provided_support_cbp_actor + - .dy_is_same_sex:.dy_provided_support_cbp_actor + + .is_same_sex:.provided_support_cbp_actor + # Composition-specific between-person partner effects - .dy_is_female_x_male_female:.dy_provided_support_cbp_partner + - .dy_is_female_x_male_male:.dy_provided_support_cbp_partner + + .is_female_x_male_female:.provided_support_cbp_partner + + .is_female_x_male_male:.provided_support_cbp_partner + - .dy_is_same_sex:.dy_provided_support_cbp_partner + + .is_same_sex:.provided_support_cbp_partner + # stable dyad-level covariance - us(0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | coupleID) + + us(0 + .is_female_x_male_female + .is_female_x_male_male | coupleID) + - us(0 + .dy_is_same_sex | coupleID) + - us(0 + .dy_member_contrast_same_sex_arbitrary | coupleID) + + us(0 + .is_same_sex | coupleID) + + us(0 + .member_contrast_same_sex_arbitrary | coupleID) + # same-day covariance - us(0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | coupleID:diaryday) + + us(0 + .is_female_x_male_female + .is_female_x_male_male | coupleID:diaryday) + - us(0 + .dy_is_same_sex | coupleID:diaryday) + - us(0 + .dy_member_contrast_same_sex_arbitrary | coupleID:diaryday) + us(0 + .is_same_sex | coupleID:diaryday) + + us(0 + .member_contrast_same_sex_arbitrary | coupleID:diaryday) , dispformula = ~ 0 , family = gaussian() @@ -462,30 +462,30 @@ stable dyad-level covariance terms in the model above: # distinguishable female-male random intercepts and slopes us( 0 + - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + - .dy_is_female_x_male_female:.dy_provided_support_cwp_actor + - .dy_is_female_x_male_male:.dy_provided_support_cwp_actor + - .dy_is_female_x_male_female:.dy_provided_support_cwp_partner + - .dy_is_female_x_male_male:.dy_provided_support_cwp_partner | + .is_female_x_male_female + + .is_female_x_male_male + + .is_female_x_male_female:.provided_support_cwp_actor + + .is_female_x_male_male:.provided_support_cwp_actor + + .is_female_x_male_female:.provided_support_cwp_partner + + .is_female_x_male_male:.provided_support_cwp_partner | coupleID ) + # exchangeable same-sex shared block us( 0 + - .dy_is_same_sex + - .dy_is_same_sex:.dy_provided_support_cwp_actor + - .dy_is_same_sex:.dy_provided_support_cwp_partner | + .is_same_sex + + .is_same_sex:.provided_support_cwp_actor + + .is_same_sex:.provided_support_cwp_partner | coupleID ) + # exchangeable same-sex difference block us( 0 + - .dy_member_contrast_same_sex_arbitrary + - .dy_member_contrast_same_sex_arbitrary:.dy_provided_support_cwp_actor + - .dy_member_contrast_same_sex_arbitrary:.dy_provided_support_cwp_partner | + .member_contrast_same_sex_arbitrary + + .member_contrast_same_sex_arbitrary:.provided_support_cwp_actor + + .member_contrast_same_sex_arbitrary:.provided_support_cwp_partner | coupleID ) ``` diff --git a/dev/workshop/.gitignore b/dev/workshop/.gitignore index c7a5d430..c4f90bc3 100644 --- a/dev/workshop/.gitignore +++ b/dev/workshop/.gitignore @@ -2,8 +2,6 @@ **/*.quarto_ipynb /*.html !/branding.html -!/dyad-day.html -!/applied-tutorial.html /*.pdf /*_files/ *.xlsx @@ -11,4 +9,6 @@ *.rda *.RData .~lock.*# -*.rds +!/dyadic-data.rds +!/dyadic-person-means.rds +!/dyadic-ild-exercise.rds diff --git a/dev/workshop/00_setup.R b/dev/workshop/00_setup.R new file mode 100644 index 00000000..02b8f50c --- /dev/null +++ b/dev/workshop/00_setup.R @@ -0,0 +1,56 @@ +# Run this file once, in a fresh R session, before the workshop. + +cran_repository <- "https://cloud.r-project.org" + +cran_packages <- c( + "glmmTMB", + "DHARMa", + "easystats", + "dplyr", + "ggplot2", + "tibble", + "tidyr" +) + +universe_packages <- c("dyadMLM", "wbCorr") +universe_package_references <- paste0(universe_packages, "?reinstall") +workshop_packages <- c(cran_packages, universe_packages) + +options(repos = c(CRAN = cran_repository)) + +if (!requireNamespace("pak", quietly = TRUE)) { + install.packages("pak") +} + +pak::pkg_install( + cran_packages, + upgrade = FALSE, + ask = FALSE +) + +options( + repos = c( + PascalKueng = "https://pascal-kueng.r-universe.dev", + CRAN = cran_repository + ) +) + +pak::pkg_install( + universe_package_references, + upgrade = FALSE, + ask = FALSE +) + +missing_packages <- workshop_packages[ + !vapply(workshop_packages, requireNamespace, logical(1), quietly = TRUE) +] + +if (length(missing_packages) > 0) { + stop( + "Workshop setup failed for: ", + paste(missing_packages, collapse = ", "), + call. = FALSE + ) +} + +message("Workshop setup complete. Restart R before beginning the exercises.") diff --git a/dev/workshop/03_exercises_cross_sectional.Rmd b/dev/workshop/03_exercises_cross_sectional.Rmd new file mode 100644 index 00000000..1fcecbb5 --- /dev/null +++ b/dev/workshop/03_exercises_cross_sectional.Rmd @@ -0,0 +1,557 @@ +--- +title: "Dyadic Data Analysis with R" +subtitle: "Cross-Sectional Workshop Exercises" +author: + - "Pascal Küng" + - "Turu Stadler" +format: + html: + embed-resources: true + toc: true + toc-title: "Exercises" +editor: source +--- + +# Exercises + +These exercises follow the six-step cross-sectional APIM workflow from the +applied tutorial. + +Download the complete workshop materials at any time from the +[workshop page](https://pascal-kueng.github.io/dyadMLM/workshop/). +Package documentation and vignettes describing model fitting for dyadic MLMs +are available through the [`dyadMLM` homepage](https://pascal-kueng.github.io/dyadMLM/). + +# Getting started + +An R Markdown (`.Rmd`) file combines *Markdown* text -- such as this paragraph -- +with runnable R code chunks. + +Run code chunks individually via the small green play button in the +top-right of each chunk. Try it by running the next chunk. It installs or updates +the workshop packages and any dependencies that need updating. This may take +several minutes; you can read ahead while it runs. + +```{r eval=FALSE} +source("00_setup.R") +``` + + + +In RStudio, insert a new R chunk with +Ctrl+Alt+I on Windows or Linux, or Cmd+Option+I on macOS. + +Try it and insert a new chunk between the green lines: + +--- + + + +--- + + +Load all required packages: + +```{r} +library(glmmTMB) +library(dyadMLM) +library(easystats, quietly = TRUE) # This package likes to be especially noisy +library(DHARMa) +library(dplyr) + +source("hints.R") + +``` + + +While going through the exercises you can sometimes spot optional hints: + +```{r} +# hint("example_hint", "run_chunk_without_comment") +``` + +To reveal a hint, delete the `#` in front of the hint you want to read, then +run the chunk (again). You can try it above. + + + +------------ Let's get started! ------------------ + + + +# Loading, inspecting, and preparing the data + +Follow a simplified workflow: + +1. Define dyads, distinguishability, and research questions +2. Prepare the data and validate the dyadic structure +3. Describe and visualize measures and observed relationships +4. Estimate the model +5. Verify model adequacy, distinguishability, and robustness +6. Visualize, interpret, and report results + +# 1. Define dyads, distinguishability, and research questions + +Do not reproduce a predictor--outcome combination from the workshop examples, +such as self-efficacy predicting MVPA or received support predicting MVPA. +Any other substantively sensible combination is fine. + +Place `dyadic-person-means.rds` in the same folder as this exercise file, then +load and inspect the raw aggregated dataset: + +```{r} +raw_dyad_data <- readRDS("dyadic-person-means.rds") + +raw_dyad_data +``` + + +Choose your research question. + +> [Insert your actor research question] + +> [Insert your partner research question] + + + +# 2. Prepare the data and validate the dyadic structure + +Use `dyadMLM::prepare_dyad_data()`. For help with its arguments, run: + +```{r eval=FALSE} +?dyadMLM::prepare_dyad_data +``` + +Adding `?` before a function name opens its help page in RStudio. + +--- + +Prepare and validate the data for a **distinguishable** model now. + +- Distinguish partners using `role = gender`. +- Set `include_arbitrary_member_contrast = TRUE` to use the same prepared data + for distinguishable and exchangeable models later. +- Use `add_apim_gmc_predictors = TRUE` if you want the grand-mean-centered APIM + predictors used in the tutorial. + +Save the prepared data as `my_data`; later exercise code uses this name. + +```{r} +# hint("prepare_data", "structure") +``` + +```{r} +# Prepare the data and save it as my_data. +``` + +Inspect the prepared data (like you did above with the raw data) and verify the +dyad IDs, member IDs, roles, row counts, missingness, and generated columns +make sense: + +```{r} + +``` + + +# 3. Describe and visualize measures and observed relationships + +Adapt the summary and plotting code from the tutorial to your focal variables. +At minimum, summarize the variables by role, inspect their distributions, +calculate observed dyadic correlations, and visualize partner similarity. + +For role-specific summaries and dyadic correlations, create a wide view with +one row per couple using `tidyr::pivot_wider()`. Save it as `my_wide_data`; +continue using `my_data` for modeling. + +Summaries: + +```{r} +# hint("descriptive_summary", "functions") +# hint("descriptive_summary", "example_code") +``` + +```{r} +# Create my_wide_data and add your summaries here. +``` + +Visualize distributions by gender. The easiest way to visualize a distribution +is with `hist()`. You can select rows directly with `[rows, columns]`. + +```{r} +# hint("histograms", "example_code") +``` + +```{r} +# Pooled histogram + +# Male histogram + +# Female histogram +``` + + +Describe partner similarity: + +```{r} +# hint("partner_similarity", "correlations") +# hint("partner_similarity", "plot") +``` + +```{r} +# Correlations + +# Plot +``` + + +Describe what you see and how you interpret the summaries and plots: + +[Insert your brief summary here] + + +# 4. Estimate the model + +Inspect `names(my_data)` to find the generated columns you need in the formula. +Then estimate a model for distinguishable dyads: + +```{r eval=FALSE} +# hint("distinguishable_model", "concept") +# hint("distinguishable_model", "structure") +# hint("distinguishable_model", "example_code") +``` + +```{r eval=FALSE} +my_model <- glmmTMB( + + YOUR_MODEL_FORMULA, + + data = my_data, + family = gaussian() +) + +summary(my_model) + +``` + + + +# 5. Verify model adequacy, distinguishability, and robustness + +### Adequacy + +First, check estimation: + +- no convergence warnings +- finite estimates, standard errors, and fit indices +- no variances near zero or correlations near $-1$ or $1$ + +Then, use DHARMa for residual diagnostics via simulation: + +```{r eval=FALSE} +my_model_dharma_residuals <- DHARMa::simulateResiduals( + fittedModel = my_model, + n = 10000, + + # Re-simulate the random-effects block that represents the residuals. + simulateREs = "unconditional", + + # Account for the correlation between partners' residuals. + rotation = "estimated", + seed = 123 +) + +plot(my_model_dharma_residuals) +``` + +Next, inspect each role separately: + +```{r eval=FALSE} +female_dharma_residuals <- DHARMa::recalculateResiduals( + my_model_dharma_residuals, + sel = ~ .is_female == 1, + rotation = NULL, + seed = 123 +) + +male_dharma_residuals <- DHARMa::recalculateResiduals( + my_model_dharma_residuals, + sel = ~ .is_male == 1, + rotation = NULL, + seed = 123 +) + +# Show both role-specific plots side by side, then restore the previous layout. +old_par <- par(mfrow = c(1, 2)) +DHARMa::plotResiduals(female_dharma_residuals, main = "Women") +DHARMa::plotResiduals(male_dharma_residuals, main = "Men") +par(old_par) +``` + +Interpreting these residual diagnostics takes practice. Consult the DHARMa +vignette section on +[interpreting residuals and recognizing misspecification](https://stat.ethz.ch/CRAN/web/packages/DHARMa/vignettes/DHARMa.html#interpreting-residuals-and-recognizing-misspecification-problems). +For now, briefly assess whether the diagnostics appear acceptable overall and +for each role. + +If convergence problems or DHARMa patterns suggest a problematic outcome +scale, inspect a histogram. For a nonnegative, right-skewed outcome, try +`sqrt()` or `log1p()` (which handles zeros), check whether the histogram is less +skewed, refit the model, and rerun DHARMa. + +For some outcomes, an appropriate non-Gaussian family may be preferable to a +transformation. Generalized families have different assumptions and require +case-specific choices, so they are not covered in this workshop. If the model +remains inadequate, reconsider its mean and covariance structure before +continuing. + + +### Distinguishability + +Fit the equivalent model under exchangeability constraints. It should use the +same adequate specification and differ only in its exchangeability constraints. +Hint: you need a +`.member_contrast_arbitrary` column in the data. You may already have included +one earlier, or you may need to prepare the data again. Check your column names +with `names(my_data)`. + + +```{r} +# hint("exchangeable_model", "fixed_effects") +# hint("exchangeable_model", "random_effects") +# hint("exchangeable_model", "example_code") +# hint("outcome_scale", "matched_models") + +``` + +```{r} +# Fit the equivalent exchangeable model here. +``` + +Compare the distinguishable and exchangeable models using +`dyadMLM::compare_nested_models()`. + +```{r} + +``` + +Insert your brief conclusion, and choose whether you want to continue with +the distinguishable or exchangeable model for the rest of the exercise: + +[Insert conclusion] + +[Insert decision and reasoning] + +You may also test selected equality constraints rather than full exchangeability. +If you do, compare that model with the distinguishable model and include it in +your retention decision. + +Save the model you retained as `retained_model`: + +```{r eval=FALSE} +retained_model <- YOUR_RETAINED_MODEL +``` + + +### If exchangeable: recheck adequacy + +If you retained the distinguishable model unchanged, its adequacy was already +checked above. If you retained the exchangeable model, repeat the overall +DHARMa check: + +```{r eval=FALSE} +retained_model_dharma_residuals <- DHARMa::simulateResiduals( + fittedModel = retained_model, + n = 10000, + + # Re-simulate the random-effects block that represents the residuals. + simulateREs = "unconditional", + + # Account for the correlation between partners' residuals. + rotation = "estimated", + seed = 123 +) + +plot(retained_model_dharma_residuals) +``` + +### Robustness + +Inspect unusual dyads in separate role panels. Use the same panels if you +retained the exchangeable model: the split simply keeps one observation per +dyad in each plot and does not imply role-specific model effects. Use the same +predictor and outcome versions as in your retained model. For example, use the +generated actor or partner predictor column and, if applicable, the transformed +outcome column. + +Optionally, you can use the supplied helper that is loaded here from a separate +file `helpers.R`: + +```{r} +# hint("robustness_mahalanobis", "columns") +``` + +```{r eval=FALSE} +# The function is defined in the separate helper file. +source("helpers.R") + +women_mahalanobis_plot <- plot_mahalanobis( + data = dplyr::filter(my_data, gender == "female"), + x = "YOUR_ACTOR_PREDICTOR_COLUMN", + y = "YOUR_OUTCOME_COLUMN", + title = "Women" +) + +men_mahalanobis_plot <- plot_mahalanobis( + data = dplyr::filter(my_data, gender == "male"), + x = "YOUR_ACTOR_PREDICTOR_COLUMN", + y = "YOUR_OUTCOME_COLUMN", + title = "Men" +) + +see::plots(women_mahalanobis_plot, men_mahalanobis_plot) +``` + +Repeat the same for partner effects: + +```{r} + +``` + + +Mahalanobis distance identifies unusual bivariate combinations, not formal +model influence, and the displayed regression line is not the adjusted APIM +effect. Use the labels to guide data inspection rather than to automatically +exclude dyads. + +If a dyad was flagged for a substantive or procedural reason, optionally refit +the retained model without it: + +```{r eval=FALSE} +# hint("robustness_refit", "ids") +``` + +```{r eval=FALSE} +data_without_selected_dyads <- dplyr::filter( + my_data, + !couple_id %in% DYAD_IDS_TO_EXCLUDE +) + +model_without_selected_dyads <- update( + retained_model, + data = data_without_selected_dyads +) + +summary(model_without_selected_dyads) +``` + +Do not exclude dyads merely because their removal changes a significance label. + +Compare the focal estimates and their uncertainty with those from +`retained_model`. State whether any substantive conclusion changed: + +> [Insert your robustness conclusion] + + +# 6. Visualize, interpret, and report results + +Print a fixed-effects table for `retained_model` using +`parameters::model_parameters()`: + +```{r} +# hint("report_results", "fixed_effects") +``` + +```{r} +# Add your fixed-effects table here. +``` + +Print a random-effects table: + +```{r} +# hint("report_results", "random_effects") +``` + +```{r} +# Add your random-effects table here. +``` + +Plot the fixed effects: + +```{r} +# hint("report_results", "plot") +``` + +```{r} +# Add your fixed-effects plot here. +``` + + +Write a brief results paragraph that: + +- describes the analysis sample and any exclusions or missing-data handling +- identifies the retained model and explains the distinguishability decision +- answers the actor and partner research questions using estimates and 95% + confidence intervals, clearly stating the modeled outcome scale +- summarizes the fitted residual covariance, adequacy checks, and robustness + analysis + +Remember that the interpretation of the intercepts depends on whether you used +grand-mean-centered variables. + +If you transformed the outcome, state the modeled scale and interpret estimates +on that scale—or use back-transformed predictions. + +> [Insert your brief results paragraph] + + +You have now completed the APIM workflow! + + +## Optional: Compute DIM estimates from the exchangeable APIM + +The transformation from exchangeable APIM coefficients to DIM estimates is +particularly simple. + +Check the output from your **exchangeable** model, and enter your coefficients +here: + +```{r eval=FALSE} + +b_actor <- YOUR_ACTOR_COEFFICIENT +b_partner <- YOUR_PARTNER_COEFFICIENT + +``` + +Recover the DIM estimates: + +```{r eval=FALSE} +# hint("dim_transformation", "formulas") +``` + +```{r eval=FALSE} +b_mean <- YOUR_FORMULA +b_dev <- YOUR_FORMULA + +cat( + "The between-dyad effect is: ", round(b_mean, 2), "\n", + "The within-dyad effect is: ", round(b_dev, 2) +) + +``` + + +Interpret the effects: + +[Insert interpretation] + + +Optionally, fit a DIM or DSM directly using the package vignettes: + +- [DIM vignette](https://pascal-kueng.github.io/dyadMLM/articles/dim.html) +- [DSM vignette](https://pascal-kueng.github.io/dyadMLM/articles/dsm.html) + + +# Intensive longitudinal dyads + +You may continue with the +[intensive longitudinal exercises](04_exercises_ild.Rmd). diff --git a/dev/workshop/04_exercises_ild.Rmd b/dev/workshop/04_exercises_ild.Rmd new file mode 100644 index 00000000..28aca333 --- /dev/null +++ b/dev/workshop/04_exercises_ild.Rmd @@ -0,0 +1,576 @@ +--- +title: "Dyadic Data Analysis with R" +subtitle: "Intensive Longitudinal Workshop Exercises" +author: + - "Pascal Küng" + - "Turu Stadler" +format: + html: + embed-resources: true + toc: true + toc-title: "ILD Exercises" +editor: source +--- + +# Exercises + +These exercises extend the cross-sectional APIM workflow. + +Download the complete workshop materials at any time from the +[workshop page](https://pascal-kueng.github.io/dyadMLM/workshop/). Package +documentation and vignettes are available on the +[`dyadMLM` homepage](https://pascal-kueng.github.io/dyadMLM/). + + +# Getting started + +Keep `04_exercises_ild.Rmd`, `dyadic-ild-exercise.rds`, `00_setup.R`, +`hints.R`, and `helpers.R` in the same folder. + +If you have not already run the workshop setup, run the next chunk once, in a +fresh R session. It installs or updates the workshop packages and any +dependencies that need updating, but does not update unrelated packages. This +may take several minutes. + +```{r eval=FALSE} +source("00_setup.R") +``` + +Load the required packages, optional hints, and ILD diagnostic helpers: + +```{r message=FALSE, warning=FALSE} +library(glmmTMB) +library(dyadMLM) +library(wbCorr) +library(easystats, quietly = TRUE) +library(DHARMa) +library(dplyr) +library(ggplot2) + +source("hints.R") +source("helpers.R") +``` + +Optional hints appear as commented `hint()` calls. Uncomment and run them one +at a time. + + +# The ILD workflow + +The same six-step workflow still applies: + +1. Define dyads, roles, and research questions +2. Prepare the data and validate the dyadic structure +3. Describe and visualize measures and observed relationships +4. Estimate the models +5. Verify model adequacy, role differences, and robustness +6. Visualize, interpret, and report results + +ILD additionally requires attention to matched occasions, time gaps, +within- and between-person variation, time trends, and residual temporal +dependence. + + +# 1. Define dyads, roles, and research questions + +The cross-sectional exercise let you choose the predictor and outcome. Here, +everyone uses one prescribed question and a focused simulated dataset so that +the focus remains on the new ILD decisions and results can be compared across +groups. This is a teaching choice, not a claim that there is only one sensible +question or causal direction. + +Load and inspect the focused workshop dataset: + +```{r} +raw_ild_data <- readRDS("dyadic-ild-exercise.rds") + +raw_ild_data +``` + +The data contain **simulated daily scores for female--male dyads**. +Gender is the distinguishing variable. Higher scores indicate more provided +support and greater closeness. + +Our concurrent research question is: + +> **How are daily deviations and stable between-person differences in provided +> support associated with one's own and one's partner's closeness on the same +> day?** + +Unlike the prospective workshop example, this question concerns the same day. +Therefore, no lagged predictors are needed. + +Translate this into four questions or hypotheses: + +> [Insert the within-person actor question] + +> [Insert the within-person partner question] + +> [Insert the between-person actor question] + +> [Insert the between-person partner question] + +Briefly state what the concurrent design can and cannot establish: + +> [Insert your answer] + + +# 2. Prepare the data and validate the dyadic structure + +Prepare a **distinguishable** APIM dataset with +`dyadMLM::prepare_dyad_data()`. + +You need actor and partner variables for both the within-person and +between-person components. For help with most functions, run `?function_name`. + +Save the result as `my_ild_data`. + +```{r eval=FALSE} +# hint("ild_preparation", "solution") +``` + +```{r eval=FALSE} +my_ild_data <- dyadMLM::prepare_dyad_data( + data = raw_ild_data, + # Complete the required arguments. +) +``` + +Add two time variables: + +- `diaryday_c`: centered at the study midpoint and scaled in full-study units +- `diaryday_f`: a factor containing every scheduled day from 0 through 13 + +These names are used below. + +```{r eval=FALSE} +# hint("ild_preparation", "time_variables") +``` + +```{r eval=FALSE} +my_ild_data <- my_ild_data |> + dplyr::mutate( + # Create diaryday_c and diaryday_f. + ) +``` + +Inspect the prepared data and its generated columns: + +```{r eval=FALSE} +my_ild_data +``` + +```{r eval=FALSE} +names(my_ild_data) +``` + + +## Validate the dyadic and temporal structure + +This teaching dataset is deliberately complete and balanced. Use separate +summaries for women and men to check that both roles have the expected number +of observations and day range, and inspect variable ranges and missingness. + +```{r eval=FALSE} +my_ild_data |> + dplyr::filter(gender == "male") |> + dplyr::select(diaryday, provided_support, closeness) |> + report::report_table() + +my_ild_data |> + dplyr::filter(gender == "female") |> + dplyr::select(diaryday, provided_support, closeness) |> + report::report_table() +``` + +Summarize what you found: + +> [Insert your data-structure and missingness summary] + + +# 3. Describe and visualize measures and observed relationships + + +## Describe the focal variables + +Reuse the simple tools from the cross-sectional exercise: summarize +`provided_support` and `closeness` overall and by role, then inspect +role-specific histograms. Means and standard deviations are sufficient here. + +```{r} +# hint("ild_descriptives", "summary") +``` + +```{r} +# Add your overall and role-specific summaries here. +``` + +```{r} +# hint("ild_descriptives", "histograms") +``` + +```{r} +# Add your role-specific histograms here. +``` + + +## Plot paired trajectories + +Plot both variables over time for a manageable selection of dyads. Make the two +members identifiable and avoid drawing every trajectory in one panel. + +```{r eval=FALSE} +trajectory_dyads <- sort(unique(my_ild_data$coupleID))[1:4] + +trajectory_data <- my_ild_data |> + dplyr::filter(coupleID %in% trajectory_dyads) |> + dplyr::select( + coupleID, personID, diaryday, gender, + provided_support, closeness + ) |> + tidyr::pivot_longer( + cols = c(provided_support, closeness), + names_to = "measure", + values_to = "score" + ) +``` + +```{r} +# hint("ild_trajectories", "structure") +# hint("ild_trajectories", "solution") +``` + +```{r} +# Complete the mappings and facet specification, then run the plot: +# ggplot2::ggplot( +# trajectory_data, +# ggplot2::aes( +# x = ..., +# y = ..., +# color = ..., +# group = ... +# ) +# ) + +# ggplot2::geom_line(na.rm = TRUE) + +# ggplot2::geom_point(na.rm = TRUE) + +# ggplot2::facet_grid(... ~ ..., scales = "free_y") + +# ggplot2::labs(x = "Diary day", y = NULL, color = "Gender") + +# ggplot2::theme_minimal() +``` + + +## Optional extension: separate within- and between-person information + +If time permits, adapt the wide-data correlation workflow from the +cross-sectional exercise. Create one row per couple and day, with separate +female and male columns for each focal variable. Then use `wbCorr()` with +`coupleID` as the cluster to inspect: + +- ICCs for each role-specific series +- correlations among daily deviations within couples +- correlations among role-specific person means between couples + +Map the relevant entries to the actor and partner questions. Treat these +correlations as descriptive rather than as replacements for the APIM. +Multilevel reliability would also matter for multi-item measures, but the +item-level data needed to estimate it are not included here. + +```{r} +# hint("ild_level_associations", "structure") +# hint("ild_level_associations", "solution") +``` + +```{r} +# Add your optional level-specific association code here. +``` + +Describe the main patterns: + +> [Insert your descriptive interpretation] + + +# 4. Estimate the role-specific AR(1) model + +Fit a Gaussian distinguishable APIM with: + +- role-specific intercepts and linear time trends +- role-specific within-person actor and partner effects +- role-specific between-person actor and partner effects +- stable role-specific covariance at the dyad level +- separate female and male AR(1) residual processes +- same-occasion role-specific covariance at the dyad--day level + +Use `dispformula = ~ 0` so the modeled dyad--day block represents the Gaussian +observation-level residual structure. Adapt the distinguishable ILD model from +the applied tutorial and inspect `names(my_ild_data)` when selecting columns. + +The applied tutorial shows how residual temporal dependence motivates AR(1). +For this focused extension, fit the planned role-specific AR(1) specification +directly. This avoids spending workshop time estimating a deliberately +misspecified no-AR intermediate model. + +To keep this exercise focused and fitting times manageable, use random +intercepts but no random slopes. In substantive analyses, consider +theoretically plausible within-person random slopes when the data can support +them; their omission here is a teaching and computational simplification. + +The covariance model has several components. Use this tested optimizer control +for every candidate so that the comparison does not also change the estimation +strategy: + +```{r} +ild_control <- glmmTMB::glmmTMBControl( + profile = TRUE, + optimizer = stats::optim, + optArgs = list(method = "BFGS"), + optCtrl = list(maxit = 2000, reltol = 1e-10) +) +``` + +```{r eval=FALSE} +# hint("ild_ar1", "role_specific_syntax") +# hint("ild_models", "distinguishable_ar1") +``` + +```{r eval=FALSE} +ild_ar1_start <- make_ild_ar1_start(my_ild_data) + +distinguishable_ar1_model <- glmmTMB::glmmTMB( + formula = YOUR_ROLE_SPECIFIC_AR1_FORMULA, + dispformula = ~ 0, + family = gaussian(), + data = my_ild_data, + control = ild_control, + start = ild_ar1_start +) + +summary(distinguishable_ar1_model) +``` + +The start helper fits only an ordinary fixed-effects regression, then supplies +generic interior values for the covariance parameters. It does not fit a +mixed model or use the simulation truth. + +Inspect the model output for convergence or Hessian warnings, boundary +estimates, and the plausibility of all estimates before continuing. A zero +convergence code is not enough when the Hessian is non-positive-definite or a +covariance estimate is on its boundary. + + +# 5. Verify model adequacy, role differences, and robustness + + +## Does the model reproduce the temporal dependence? + +Use the workshop helper to simulate block-whitened DHARMa residuals. The helper +accounts for fitted dependence within each dyad rather than treating every +person-day as independent. Pass `role` and request `by_role = TRUE` so the +female and male lag-1 checks are not averaged together. + +```{r eval=FALSE} +distinguishable_dharma_residuals <- simulate_ild_dharma( + model = distinguishable_ar1_model, + dyad = my_ild_data$coupleID, + member = my_ild_data$personID, + time = my_ild_data$diaryday, + role = my_ild_data$gender, + n = 250, + seed = 123 +) + +plot( + distinguishable_dharma_residuals, + title = "Block-whitened DHARMa residuals" +) + +test_ild_lag1(distinguishable_dharma_residuals, by_role = TRUE) +``` + +Consider: + +- overall calibration and visible residual patterns +- the magnitude of the observed lag-1 correlation for each role +- whether each correlation is typical under simulations from the fitted model + +The plot uses block-whitened scaled residuals. The lag-1 helper instead uses a +raw response-residual correlation and compares it with the same statistic in +simulations from the fitted model. + +The exercise uses 250 simulations to keep this extension manageable during the +workshop. Increase that number for a final substantive analysis. + +Do not base the decision on a significance label alone. + +> [Insert your diagnostic interpretation] + +```{r eval=FALSE} +# hint("ild_diagnostics", "solution") +``` + +Use one stable name for the model comparison: + +```{r eval=FALSE} +distinguishable_model <- distinguishable_ar1_model +``` + + +## Do the focal associations differ by role? + +The cross-sectional exercise covered a global exchangeability test. Here, use a +more focused comparison: pool only the four within- and between-person +actor/partner associations. Keep role-specific intercepts, time trends, stable +covariance, same-occasion covariance, and both AR(1) processes unchanged. + +This creates a regular four-degree-of-freedom test of one clear question: + +> **Do the four focal APIM associations differ between women and men?** + +Because the temporal and covariance terms are identical in both candidates, +the comparison does not mix that question with a change in residual structure. + +```{r eval=FALSE} +# hint("ild_models", "pooled_apim_effects") +``` + +```{r eval=FALSE} +pooled_apim_effects_start <- make_pooled_apim_effects_start( + distinguishable_model +) + +pooled_apim_effects_model <- update( + distinguishable_model, + formula = YOUR_POOLED_EFFECTS_FORMULA_UPDATE, + start = pooled_apim_effects_start +) + +summary(pooled_apim_effects_model) +``` + +Check estimation, then compare the matched models: + +```{r eval=FALSE} +dyadMLM::compare_nested_models( + distinguishable_model, + pooled_apim_effects_model +) +``` + +Choose the model you will retain. Consider statistical evidence, parsimony, and +whether common actor and partner associations are substantively defensible. +Do not call the restricted model exchangeable: its baseline, covariance, and +AR(1) parameters remain role-specific. + +> [Insert your role-difference conclusion and decision] + +Use one stable name for all further processing and reporting: + +After making your role-difference decision, you can reveal the optional +checkpoint and compare whether you reached the same conclusion. + +```{r eval=FALSE} +# hint("ild_model_choices", "role_solution") +``` + +```{r eval=FALSE} +retained_model <- YOUR_RETAINED_MODEL +``` + + +## If pooled: recheck adequacy + +If you retained `pooled_apim_effects_model`, repeat the DHARMa and lag-1 checks +with `retained_model`. If you retained the already-checked distinguishable +model, skip this step. + +```{r eval=FALSE} +retained_model_dharma_residuals <- simulate_ild_dharma( + model = retained_model, + dyad = my_ild_data$coupleID, + member = my_ild_data$personID, + time = my_ild_data$diaryday, + role = my_ild_data$gender, + n = 250, + seed = 123 +) + +plot( + retained_model_dharma_residuals, + title = "Retained-model block-whitened residuals" +) + +test_ild_lag1(retained_model_dharma_residuals, by_role = TRUE) +``` + +Briefly assess whether the pooled-effects model remains adequate: + +> [Insert your conclusion, or state that you skipped this step] + + +## Robustness + +If time permits, assess a different plausible time trend and compare the focal +estimates. In a substantive analysis, you could also assess theoretically +plausible random slopes if the design supports them. Do not select a +specification solely because it changes a significance label. + +> [Insert your robustness conclusion] + +For a future nonnegative, right-skewed outcome, `sqrt()` or `log1p()` may +improve the scale; inspect its histogram, refit, and rerun all diagnostics. An +appropriate non-Gaussian family may instead be preferable, but generalized +families have different assumptions and require case-specific choices. + + +# 6. Visualize, interpret, and report results + +Use `retained_model` for every table, plot, and interpretation below. + +Print the fixed and random effects, and inspect the fitted covariance +parameters: + +```{r} +# hint("ild_reporting", "solution") +``` + +```{r} +# Add your reporting code here. +``` + +Interpret each AR(1) SD as the stationary SD of that role's persistent latent +residual process. The dyad--day correlation describes only the remaining +nonpersistent same-occasion component; it is not the correlation of the +complete residual after the AR(1) components are added. + +Plot the focal fixed effects or model-implied associations: + +```{r} +# hint("ild_reporting", "plot") +``` + +```{r} +# Add your plotting code here. +``` + +Write a brief results paragraph that: + +- describes the analysis sample and temporal structure +- explains the selected temporal specification +- explains the role-difference decision +- reports within-person and between-person actor and partner effects with + estimates and 95% confidence intervals +- summarizes stable dyad covariance, same-occasion partner covariance, and any + fitted AR(1) parameters +- reports the adequacy and robustness checks + +Interpret the estimates as associations, not causal effects. If effects are +role-specific, a significant estimate for one role and a nonsignificant +estimate for the other do not by themselves establish that the roles differ. + +```{r} +# hint("ild_reporting", "paragraph_template") +``` + +> [Insert your brief results paragraph] + + +You have now completed the ILD APIM workflow! diff --git a/dev/workshop/R/build-person-means.R b/dev/workshop/R/build-person-means.R new file mode 100644 index 00000000..360c6f79 --- /dev/null +++ b/dev/workshop/R/build-person-means.R @@ -0,0 +1,441 @@ +library(dplyr) + +workshop_dir <- if (dir.exists(file.path("dev", "workshop"))) { + file.path("dev", "workshop") +} else { + "." +} + +daily_file <- file.path(workshop_dir, "dyadic-data.rds") +full_file <- file.path(workshop_dir, "long.rds") + +daily <- readRDS(daily_file) +full <- readRDS(full_file) + +standardize_efficacy_name <- function(data, candidates) { + if ("efficacy" %in% names(data)) { + return(data) + } + + source <- candidates[candidates %in% names(data)] + if (length(source) != 1) { + stop("Could not identify exactly one efficacy variable.") + } + + names(data)[names(data) == source] <- "efficacy" + data +} + +daily <- standardize_efficacy_name(daily, "self_efficacy") +full <- standardize_efficacy_name(full, c("self_efficacy", "ss_eff")) + +recode_gender <- function(x) { + x <- as.character(x) + x[x == "1"] <- "female" + x[x == "2"] <- "male" + factor(x, levels = c("female", "male")) +} + +couple_ids <- sort(unique(full$coupleID)) +person_ids <- sort(unique(full$userID)) + +if (all(c("coupleID", "personID") %in% names(daily))) { + stopifnot( + setequal(unique(daily$coupleID), couple_ids), + setequal(unique(daily$personID), person_ids) + ) + + daily <- daily |> + mutate( + couple_id = match(coupleID, couple_ids), + person_id = match(personID, person_ids), + gender = recode_gender(gender) + ) |> + select( + couple_id, person_id, diaryday, gender, + everything(), -coupleID, -personID + ) +} else { + daily <- daily |> + mutate(gender = recode_gender(gender)) +} + +full <- full |> + mutate( + couple_id = match(coupleID, couple_ids), + person_id = match(userID, person_ids), + gender = recode_gender(gender), + perceived_behavioral_control = .data[["ss _res"]], + device_based_mvpa = minutes_mvpa_wearawake_filtered, + awake_wear_minutes = wear_awake_minutes + ) |> + select(-any_of(c("perceived_resources", "objective_mvpa"))) |> + relocate(couple_id, person_id, gender) |> + relocate( + perceived_behavioral_control, + device_based_mvpa, + awake_wear_minutes, + .after = last_col() + ) + +mixed_gender_couples <- full |> + distinct(couple_id, person_id, gender) |> + group_by(couple_id) |> + summarise( + n_people = n(), + n_female = sum(gender == "female"), + n_male = sum(gender == "male"), + .groups = "drop" + ) |> + filter(n_people == 2, n_female == 1, n_male == 1) |> + pull(couple_id) + +daily <- daily |> + filter(couple_id %in% mixed_gender_couples) + +full <- full |> + filter(couple_id %in% mixed_gender_couples) + +retained_couple_ids <- sort(unique(full$couple_id)) +retained_person_ids <- sort(unique(full$person_id)) + +daily <- daily |> + mutate( + couple_id = match(couple_id, retained_couple_ids), + person_id = match(person_id, retained_person_ids) + ) + +full <- full |> + mutate( + couple_id = match(couple_id, retained_couple_ids), + person_id = match(person_id, retained_person_ids) + ) + +daily_key <- paste( + daily$couple_id, + daily$person_id, + daily$diaryday +) +full_key <- paste( + full$couple_id, + full$person_id, + full$day +) +daily_to_full <- match(daily_key, full_key) +if (anyNA(daily_to_full)) { + stop("Could not align all daily rows to the full data.", call. = FALSE) +} + +daily$perceived_behavioral_control <- + full$perceived_behavioral_control[daily_to_full] +daily <- daily |> + select(-any_of(c("perceived_resources", "objective_mvpa"))) +daily$device_based_mvpa <- + full$device_based_mvpa[daily_to_full] +daily$awake_wear_minutes <- + full$awake_wear_minutes[daily_to_full] +daily <- daily |> + relocate( + perceived_behavioral_control, + device_based_mvpa, + awake_wear_minutes, + .after = last_col() + ) + +generate_sedentary <- function(data, seed = 20260728L, skew = 0.02) { + required_columns <- c( + "couple_id", "person_id", "diaryday", "gender", + "provided_support", "total_mvpa" + ) + missing_columns <- setdiff(required_columns, names(data)) + if (length(missing_columns) > 0L) { + stop( + "Missing columns: ", + paste(missing_columns, collapse = ", "), + call. = FALSE + ) + } + + simulation_data <- data |> + mutate(.original_row = row_number()) |> + arrange(couple_id, diaryday, person_id) + + rows_per_dyad_day <- simulation_data |> + count(couple_id, diaryday, name = "number_of_rows") + if (any(rows_per_dyad_day$number_of_rows != 2L)) { + stop("Every dyad-day must contain exactly two members.", call. = FALSE) + } + + support_means <- simulation_data |> + summarise( + support_mean = mean(provided_support, na.rm = TRUE), + .by = c(couple_id, person_id) + ) + if (any(!is.finite(support_means$support_mean))) { + stop("Every person needs an observed support value.", call. = FALSE) + } + + simulation_data <- simulation_data |> + left_join( + support_means, + by = c("couple_id", "person_id"), + relationship = "many-to-one" + ) |> + mutate( + support_cwp_actor = provided_support - support_mean + ) |> + group_by(couple_id, diaryday) |> + mutate( + support_cwp_partner = rev(support_cwp_actor), + member_contrast = c(1, -1) + ) |> + ungroup() + + set.seed(seed) + + dyads <- sort(unique(simulation_data$couple_id)) + stable_effects <- data.frame( + couple_id = dyads, + stable_shared = rnorm(length(dyads), 0, 32), + stable_difference = rnorm(length(dyads), 0, 24) + ) + + day_shared_sd <- 43 + day_difference_sd <- 37 + # Similar, but not identical, member-specific AR(1) processes by role. + ar_sd_by_role <- c(female = 40, male = 44) + ar_rho_by_role <- c(female = 0.35, male = 0.45) + + simulation_data <- simulation_data |> + left_join( + stable_effects, + by = "couple_id", + relationship = "many-to-one" + ) |> + mutate( + fixed_and_stable = ( + 540 - + 8 * coalesce(support_cwp_actor, 0) - + 4 * coalesce(support_cwp_partner, 0) + + stable_shared + + member_contrast * stable_difference + ) + ) + + person_rows <- split( + seq_len(nrow(simulation_data)), + interaction( + simulation_data$couple_id, + simulation_data$person_id, + drop = TRUE + ) + ) + ar_state <- numeric(nrow(simulation_data)) + for (rows in person_rows) { + rows <- rows[order(simulation_data$diaryday[rows])] + if (anyDuplicated(simulation_data$diaryday[rows])) { + stop("Each member must have at most one row per day.", call. = FALSE) + } + + role <- as.character(simulation_data$gender[rows[1]]) + rho <- ar_rho_by_role[[role]] + stationary_sd <- ar_sd_by_role[[role]] + ar_state[rows[1]] <- rnorm(1, 0, stationary_sd) + innovations <- rnorm( + length(rows) - 1L, + 0, + stationary_sd * sqrt(1 - rho^2) + ) + for (day in seq.int(2L, length(rows))) { + ar_state[rows[day]] <- rho * ar_state[rows[day - 1L]] + + innovations[day - 1L] + } + } + + day_member_sd <- sqrt(day_shared_sd^2 + day_difference_sd^2) + + dyad_day <- interaction( + simulation_data$couple_id, + simulation_data$diaryday, + drop = TRUE + ) + dyad_day_rows <- split(seq_len(nrow(simulation_data)), dyad_day) + day_rough <- numeric(nrow(simulation_data)) + generation_attempts <- integer(length(dyad_day_rows)) + + for (i in seq_along(dyad_day_rows)) { + rows <- dyad_day_rows[[i]] + accepted <- FALSE + + while (!accepted && generation_attempts[[i]] < 10000L) { + generation_attempts[[i]] <- generation_attempts[[i]] + 1L + day_shared <- rnorm(1, 0, day_shared_sd) + day_difference <- rnorm(1, 0, day_difference_sd) + day_normal <- day_shared + + simulation_data$member_contrast[rows] * day_difference + day_standardized <- day_normal / day_member_sd + candidate_day_rough <- day_member_sd * ( + day_standardized + + skew * (day_standardized^2 - 1) + ) / sqrt(1 + 2 * skew^2) + candidate_sedentary <- round( + simulation_data$fixed_and_stable[rows] + + ar_state[rows] + + candidate_day_rough + ) + + constrained <- !is.na(simulation_data$total_mvpa[rows]) + accepted <- all( + candidate_sedentary[constrained] >= 0 & + candidate_sedentary[constrained] + + simulation_data$total_mvpa[rows][constrained] <= + 19 * 60 + ) + } + + if (!accepted) { + stop( + "Could not generate a valid sedentary value for one dyad-day.", + call. = FALSE + ) + } + day_rough[rows] <- candidate_day_rough + } + + simulation_data |> + mutate( + sedentary = round(fixed_and_stable + ar_state + day_rough), + sedentary = if_else( + is.na(total_mvpa), + NA_real_, + sedentary + ) + ) |> + arrange(.original_row) |> + pull(sedentary) +} + +daily$sedentary <- generate_sedentary(daily) + +daily_key <- paste( + daily$couple_id, + daily$person_id, + daily$diaryday +) +full_key <- paste( + full$couple_id, + full$person_id, + full$day +) +sedentary_index <- match(full_key, daily_key) +if (anyNA(sedentary_index)) { + stop("Could not align all full-data rows to the daily data.", call. = FALSE) +} +full$sedentary <- daily$sedentary[sedentary_index] + +couple_ids <- sort(unique(full$couple_id)) +person_ids <- sort(unique(full$person_id)) + +genders_per_person <- daily |> + distinct(couple_id, person_id, gender) |> + count(couple_id, person_id, name = "n_genders") + +person_means <- daily |> + select( + couple_id, + person_id, + gender, + provided_support, + received_support, + collaborative_planning, + exerted_persuasion, + experienced_persuasion, + efficacy, + solo_mvpa, + joint_mvpa, + total_mvpa, + sedentary + ) |> + group_by(couple_id, person_id) |> + summarise( + gender = first(gender), + across(where(is.numeric), ~ mean(.x, na.rm = TRUE)), + .groups = "drop" + ) + +numeric_columns <- person_means[vapply(person_means, is.numeric, logical(1))] +observed_sedentary <- daily$sedentary[is.finite(daily$sedentary)] +sedentary_skewness <- mean( + (observed_sedentary - mean(observed_sedentary))^3 +) / sd(observed_sedentary)^3 +jointly_observed_time <- is.finite(daily$sedentary) & + is.finite(daily$total_mvpa) + +stopifnot( + all(genders_per_person$n_genders == 1), + identical(sort(unique(daily$couple_id)), seq_len(length(couple_ids))), + identical(sort(unique(daily$person_id)), seq_len(length(person_ids))), + identical(sort(unique(full$couple_id)), seq_len(length(couple_ids))), + identical(sort(unique(full$person_id)), seq_len(length(person_ids))), + !anyDuplicated(person_means[c("couple_id", "person_id")]), + all(table(person_means$couple_id) == 2), + all(table(person_means$couple_id, person_means$gender) == 1), + all(!is.na(person_means$gender)), + all(!is.na(daily$gender)), + all(!is.na(full$gender)), + "efficacy" %in% names(daily), + "efficacy" %in% names(full), + "efficacy" %in% names(person_means), + all( + c( + "perceived_behavioral_control", + "device_based_mvpa", + "awake_wear_minutes" + ) %in% names(daily) + ), + "sedentary" %in% names(daily), + "sedentary" %in% names(full), + "sedentary" %in% names(person_means), + !any(c("self_efficacy", "ss_eff") %in% names(daily)), + !any(c("self_efficacy", "ss_eff") %in% names(full)), + !any(c("self_efficacy", "ss_eff") %in% names(person_means)), + !"perceived_resources" %in% names(daily), + !"perceived_resources" %in% names(full), + !"perceived_resources" %in% names(person_means), + !"objective_mvpa" %in% names(daily), + !"objective_mvpa" %in% names(full), + !"objective_mvpa" %in% names(person_means), + identical( + daily$perceived_behavioral_control, + full$perceived_behavioral_control[daily_to_full] + ), + identical( + daily$device_based_mvpa, + full$device_based_mvpa[daily_to_full] + ), + identical( + daily$awake_wear_minutes, + full$awake_wear_minutes[daily_to_full] + ), + identical(daily$sedentary[sedentary_index], full$sedentary), + all(observed_sedentary >= 0), + mean(observed_sedentary) > 500, + mean(observed_sedentary) < 580, + sd(observed_sedentary) > 60, + sd(observed_sedentary) < 110, + sedentary_skewness > -0.1, + sedentary_skewness < 0.5, + all( + daily$sedentary[jointly_observed_time] + + daily$total_mvpa[jointly_observed_time] <= + 19 * 60 + ), + all(vapply(numeric_columns, \(x) all(is.finite(x)), logical(1))) +) + +saveRDS(daily, daily_file) +saveRDS(full, full_file) +saveRDS( + person_means, + file.path(workshop_dir, "dyadic-person-means.rds") +) diff --git a/dev/workshop/R/draw-apim-exchangeability.R b/dev/workshop/R/draw-apim-exchangeability.R index f779ec70..52b6ef44 100644 --- a/dev/workshop/R/draw-apim-exchangeability.R +++ b/dev/workshop/R/draw-apim-exchangeability.R @@ -382,7 +382,7 @@ draw_apim_exchangeability_comparison <- function() { draw_coloured_equation( list( - "Illustrative example:", + "GM-centered example:", expression(X[plain(F)] == +1 * "," ~~ X[plain(M)] == +1) ), rep(muted_colour, 2), 0.255, 0.716, fontsize = 12.0, @@ -390,7 +390,7 @@ draw_apim_exchangeability_comparison <- function() { ) draw_coloured_equation( list( - "Illustrative example:", + "GM-centered example:", expression(X[1] == +1 * "," ~~ X[2] == +1) ), rep(muted_colour, 2), 0.745, 0.716, fontsize = 12.0, diff --git a/dev/workshop/R/draw-dyadic-response-surface.R b/dev/workshop/R/draw-dyadic-response-surface.R new file mode 100644 index 00000000..13f74e1a --- /dev/null +++ b/dev/workshop/R/draw-dyadic-response-surface.R @@ -0,0 +1,117 @@ +draw_dyadic_response_surface <- function(result) { + if (!inherits(result, "workshop_drsa")) { + stop("`result` must come from `fit_dyadic_response_surface()`.") + } + + # The model is fitted in long format. For plotting, place both outcomes on + # one row per couple while retaining the fixed female and male support axes. + plot_data <- result$data |> + dplyr::select( + couple_id, role, total_mvpa, + female_support_c, male_support_c + ) |> + tidyr::pivot_wider( + id_cols = c(couple_id, female_support_c, male_support_c), + names_from = role, + values_from = total_mvpa, + names_glue = "{role}_mvpa" + ) + + # Use shared horizontal and vertical limits so the two surfaces are directly + # comparable. The vertical limits cover both fitted polynomial surfaces. + xy_range <- range( + c(plot_data$female_support_c, plot_data$male_support_c), + finite = TRUE + ) + xy_padding <- 0.015 * diff(xy_range) + xy_limit <- xy_range + c(-xy_padding, xy_padding) + + surface_value <- function(coefficients, x, y) { + coefficients[["b0"]] + + coefficients[["x"]] * x + + coefficients[["y"]] * y + + coefficients[["x2"]] * x^2 + + coefficients[["xy"]] * x * y + + coefficients[["y2"]] * y^2 + } + + plot_grid <- expand.grid( + x = seq(xy_limit[1], xy_limit[2], length.out = 101), + y = seq(xy_limit[1], xy_limit[2], length.out = 101) + ) + grid_predictions <- unlist(lapply( + result$surface_coefficients, + \(coefficients) surface_value( + coefficients, plot_grid$x, plot_grid$y + ) + )) + z_limit <- c( + floor(min(0, grid_predictions) / 50) * 50, + ceiling(max(grid_predictions) / 50) * 50 + ) + + palette <- grDevices::colorRampPalette( + c("#F8FAFC", "#BFE4EA", "#00A6B2", "#0028A5") + )(24) + + axes_styles <- list( + LOC = list(lty = "solid", lwd = 2, col = "#1769AA"), + LOIC = list(lty = "dashed", lwd = 2, col = "#7B3FA1") + ) + + draw_partner_surface <- function(role) { + coefficients <- result$surface_coefficients[[role]] + outcome <- paste0(role, "_mvpa") + + RSA::plotRSA( + x = coefficients[["x"]], + y = coefficients[["y"]], + x2 = coefficients[["x2"]], + y2 = coefficients[["y2"]], + xy = coefficients[["xy"]], + b0 = coefficients[["b0"]], + xlim = xy_limit, + ylim = xy_limit, + zlim = z_limit, + xlab = "Female-provided emotional\nsupport (centered)", + ylab = "Male-provided emotional\nsupport (centered)", + zlab = "Predicted value", + main = paste0(tools::toTitleCase(role), " total MVPA (min/day)"), + legend = FALSE, + param = FALSE, + axes = c("LOC", "LOIC"), + axesStyles = axes_styles, + project = c("contour", "LOC", "LOIC", "points"), + points = list( + data = data.frame( + plot_data$female_support_c, + plot_data$male_support_c, + plot_data[[outcome]] + ), + show = TRUE, + value = "predicted", + jitter = 0, + color = "#20252B", + cex = 0.38 + ), + hull = TRUE, + border = FALSE, + gridsize = 23, + pal = palette, + pal.range = "box", + distance = c(1.05, 1.05, 1.1), + cex.tickLabel = 0.66, + cex.axesLabel = 0.74, + cex.main = 0.90, + pad = 0.35 + ) + } + + plots <- lapply(c("female", "male"), draw_partner_surface) + + gridExtra::grid.arrange( + grobs = plots, + ncol = 2, + padding = grid::unit(0.15, "line") + ) +} diff --git a/dev/workshop/R/draw-truth-bias.R b/dev/workshop/R/draw-truth-bias.R new file mode 100644 index 00000000..a59d1d17 --- /dev/null +++ b/dev/workshop/R/draw-truth-bias.R @@ -0,0 +1,347 @@ +draw_truth_bias_diagram <- function(result = NULL) { + bias_colour <- .interdep_diagram_colours$actor + truth_colour <- .interdep_diagram_colours$partner + ink_colour <- "#263238" + muted_colour <- "#64748B" + node_fill <- "#F8FAFC" + sans_family <- "Liberation Sans" + + fitted <- !is.null(result) + if (fitted) { + if (!inherits(result, "workshop_truth_bias")) { + stop( + "`result` must be returned by `fit_truth_bias()`.", + call. = FALSE + ) + } + + required_estimates <- c( + "intercept_female", "intercept_male", + "bias_female", "bias_male", "truth_female", "truth_male" + ) + required_residuals <- c("sd_female", "sd_male", "correlation") + required_similarity <- c("estimate", "p_value") + + if ( + !all(required_estimates %in% names(result$estimates)) || + !all(required_estimates %in% names(result$p_values)) || + !all(required_residuals %in% names(result$residuals)) || + !all(required_similarity %in% names(result$actual_similarity)) + ) { + stop("The fitted Truth and Bias result is incomplete.", call. = FALSE) + } + } + + estimate_label <- function(label, value, p_value = NULL) { + # Avoid displaying a tiny negative estimate as "-0.00" at two decimals. + if (is.finite(value) && abs(value) < 0.005) { + value <- 0 + } + .diagram_estimate_label(label, value, p_value) + } + + native <- function(value) grid::unit(value, "native") + arrow_head <- grid::arrow( + angle = 28, + length = grid::unit(0.15, "inches"), + type = "closed" + ) + covariance_arrow <- grid::arrow( + angle = 26, + length = grid::unit(0.10, "inches"), + ends = "both", + type = "closed" + ) + + draw_text <- function( + label, x, y, colour = ink_colour, fontsize = 14, + fontface = "plain", just = "centre") { + is_math <- is.expression(label) || is.language(label) + if (is_math) { + label <- .diagram_math_label(label) + } + grid::grid.text( + label, + x = native(x), + y = native(y), + just = just, + gp = grid::gpar( + col = colour, + fontsize = fontsize, + fontface = fontface, + fontfamily = if (is_math) "" else sans_family + ) + ) + } + + draw_node <- function(x, y, symbol, description, width = 0.25) { + description_size <- if (nchar(description) > 21L) 12.2 else 13.3 + grid::grid.roundrect( + x = native(x), + y = native(y), + width = native(width), + height = native(0.22), + r = grid::unit(0.09, "snpc"), + gp = grid::gpar(fill = node_fill, col = ink_colour, lwd = 1.8) + ) + draw_text( + description, x, y + 0.035, + fontsize = description_size, fontface = "bold" + ) + draw_text(symbol, x, y - 0.040, fontsize = 18) + } + + draw_residual <- function(x, y, label) { + grid::grid.circle( + x = native(x), + y = native(y), + r = grid::unit(0.052, "snpc"), + gp = grid::gpar(fill = "white", col = ink_colour, lwd = 1.8) + ) + draw_text(label, x, y, fontsize = 17) + } + + draw_path <- function(x0, y0, x1, y1, colour) { + grid::grid.segments( + x0 = native(x0), + y0 = native(y0), + x1 = native(x1), + y1 = native(y1), + arrow = arrow_head, + gp = grid::gpar(col = colour, fill = colour, lwd = 2.2) + ) + } + + draw_path_label <- function(x, y, label, colour) { + label <- .diagram_math_label(label) + label_grob <- grid::textGrob( + label, + x = native(x), + y = native(y), + gp = grid::gpar(col = colour, fontsize = 15) + ) + grid::grid.roundrect( + x = native(x), + y = native(y), + width = grid::grobWidth(label_grob) + grid::unit(2.5, "mm"), + height = grid::grobHeight(label_grob) + grid::unit(1.5, "mm"), + r = grid::unit(0.02, "snpc"), + gp = grid::gpar(fill = "white", col = NA) + ) + grid::grid.draw(label_grob) + } + + draw_intercept <- function(x, y, label) { + label <- .diagram_math_label(label) + grid::grid.roundrect( + x = native(x), + y = native(y), + width = native(if (fitted) 0.16 else 0.09), + height = native(0.065), + r = grid::unit(0.02, "snpc"), + gp = grid::gpar(fill = "white", col = muted_colour, lwd = 1) + ) + draw_text(label, x, y, colour = muted_colour, fontsize = 14) + } + + draw_covariance <- function( + x1, y1, x2, y2, curvature, label, label_x, label_y, + fontsize = 14) { + grid::grid.curve( + x1 = native(x1), + y1 = native(y1), + x2 = native(x2), + y2 = native(y2), + curvature = curvature, + angle = 90, + ncp = 12, + square = FALSE, + arrow = covariance_arrow, + gp = grid::gpar( + col = muted_colour, + fill = muted_colour, + lwd = 1.8 + ) + ) + .draw_residual_annotation( + label, label_x, label_y, + fontsize = fontsize, colour = muted_colour + ) + } + + grid::grid.newpage() + grid::pushViewport(grid::viewport(xscale = c(0, 1), yscale = c(0, 1))) + grid::grid.rect(gp = grid::gpar(fill = "white", col = NA)) + + if (fitted) { + intercept_labels <- list( + female = estimate_label( + expression(b[0 * "," * plain(F)]), + result$estimates[["intercept_female"]], + result$p_values[["intercept_female"]] + ), + male = estimate_label( + expression(b[0 * "," * plain(M)]), + result$estimates[["intercept_male"]], + result$p_values[["intercept_male"]] + ) + ) + bias_labels <- list( + female = estimate_label( + expression(b[plain(F)]), + result$estimates[["bias_female"]], + result$p_values[["bias_female"]] + ), + male = estimate_label( + expression(b[plain(M)]), + result$estimates[["bias_male"]], + result$p_values[["bias_male"]] + ) + ) + truth_labels <- list( + female = estimate_label( + expression(italic(t)[plain(F)]), + result$estimates[["truth_female"]], + result$p_values[["truth_female"]] + ), + male = estimate_label( + expression(italic(t)[plain(M)]), + result$estimates[["truth_male"]], + result$p_values[["truth_male"]] + ) + ) + residual_labels <- list( + female = estimate_label( + expression(sigma[epsilon[plain(F)]]), + result$residuals[["sd_female"]] + ), + male = estimate_label( + expression(sigma[epsilon[plain(M)]]), + result$residuals[["sd_male"]] + ), + correlation = estimate_label( + expression(rho[epsilon[plain(F)] * epsilon[plain(M)]]), + result$residuals[["correlation"]] + ) + ) + actual_similarity_label <- estimate_label( + expression(r[italic(P)[plain(F)] * "," * italic(P)[plain(M)]]), + result$actual_similarity[["estimate"]], + result$actual_similarity[["p_value"]] + ) + } else { + intercept_labels <- list( + female = expression(b[0 * "," * plain(F)]), + male = expression(b[0 * "," * plain(M)]) + ) + bias_labels <- list( + female = expression(b[plain(F)]), + male = expression(b[plain(M)]) + ) + truth_labels <- list( + female = expression(italic(t)[plain(F)]), + male = expression(italic(t)[plain(M)]) + ) + residual_labels <- list( + female = expression(sigma[epsilon[plain(F)]]), + male = expression(sigma[epsilon[plain(M)]]), + correlation = expression( + rho[epsilon[plain(F)] * epsilon[plain(M)]] + ) + ) + actual_similarity_label <- "Actual similarity" + } + + # Each provided-support report is the truth criterion for the partner's + # received-support judgment and the assumed-similarity variable for the + # person's own received-support judgment. + draw_node( + 0.17, 0.72, expression(italic(P)[plain(F)]), + "Female report:\nsupport provided" + ) + draw_node( + 0.17, 0.28, expression(italic(P)[plain(M)]), + "Male report:\nsupport provided" + ) + draw_node( + 0.64, 0.72, expression(italic(J)[plain(F)]), + "Female report:\nsupport received" + ) + draw_node( + 0.64, 0.28, expression(italic(J)[plain(M)]), + "Male report:\nsupport received" + ) + + draw_intercept(0.64, 0.86, intercept_labels$female) + draw_intercept(0.64, 0.14, intercept_labels$male) + + draw_residual(0.91, 0.72, expression(epsilon[plain(F)])) + draw_residual(0.91, 0.28, expression(epsilon[plain(M)])) + + # Same-perceiver (actor) paths are assumed-similarity bias forces. + draw_path(0.295, 0.72, 0.507, 0.72, bias_colour) + draw_path(0.295, 0.28, 0.507, 0.28, bias_colour) + draw_path_label(0.405, 0.72, bias_labels$female, bias_colour) + draw_path_label(0.405, 0.28, bias_labels$male, bias_colour) + + # Cross-partner (partner) paths are truth forces, or direct accuracy. + draw_path(0.295, 0.72, 0.507, 0.34, truth_colour) + draw_path(0.295, 0.28, 0.507, 0.66, truth_colour) + draw_path_label(0.38, 0.56, truth_labels$male, truth_colour) + draw_path_label(0.38, 0.44, truth_labels$female, truth_colour) + + # Unexplained judgments can remain interdependent. + draw_path( + 0.855, 0.72, 0.768 + .diagram_arrow_clearance, 0.72, muted_colour + ) + draw_path( + 0.855, 0.28, 0.768 + .diagram_arrow_clearance, 0.28, muted_colour + ) + draw_covariance( + 0.947, 0.68, 0.947, 0.32, curvature = -0.24, + residual_labels$correlation, + label_x = 0.90, label_y = 0.50 + ) + .draw_residual_annotation( + residual_labels$female, 0.91, 0.84, fontsize = 14 + ) + .draw_residual_annotation( + residual_labels$male, 0.91, 0.16, fontsize = 14 + ) + + # Correlated provided-support reports represent actual similarity, which + # lets assumed similarity contribute indirectly to accuracy. + draw_covariance( + 0.035, 0.66, 0.035, 0.34, curvature = 0.24, + actual_similarity_label, label_x = 0.11, + label_y = if (fitted) 0.485 else 0.50, + fontsize = if (fitted) 12.5 else 10.7 + ) + if (fitted) { + draw_text( + "Actual similarity", 0.11, 0.555, + colour = muted_colour, fontsize = 10.7 + ) + } + + .draw_diagram_legend( + labels = c( + "Assumed similarity (bias force)", + "Direct accuracy (truth force)" + ), + colours = c(bias_colour, truth_colour), + y = 0.077, + segment_starts = c(0.10, 0.52), + text_x = c(0.29, 0.70), + fontsize = 11.5 + ) + .draw_diagram_significance_key( + if (fitted) c(result$p_values, result$actual_similarity[["p_value"]]) + else NULL, + y = 0.022, + x = 0.405 + ) + + grid::popViewport() + invisible(NULL) +} diff --git a/dev/workshop/R/fit-dyadic-response-surface.R b/dev/workshop/R/fit-dyadic-response-surface.R new file mode 100644 index 00000000..f997d651 --- /dev/null +++ b/dev/workshop/R/fit-dyadic-response-surface.R @@ -0,0 +1,230 @@ +fit_dyadic_response_surface <- function(data) { + required_columns <- c( + "couple_id", "person_id", "gender", + "provided_support", "total_mvpa" + ) + missing_columns <- setdiff(required_columns, names(data)) + + if (length(missing_columns)) { + stop( + "The workshop data is missing: ", + paste(missing_columns, collapse = ", "), + call. = FALSE + ) + } + + if ( + !is.numeric(data$provided_support) || + !is.numeric(data$total_mvpa) + ) { + stop( + "`provided_support` and `total_mvpa` must be numeric.", + call. = FALSE + ) + } + + # 1. Validate the dyadic structure and create each person's actor and partner + # support values. For this example, retain female-male couples only. + prepared <- dyadMLM::prepare_dyad_data( + data, + dyad = couple_id, + member = person_id, + role = gender, + predictors = provided_support, + model_types = "apim", + keep_compositions = "female-male" + ) + + if ( + any(!is.finite(prepared$provided_support)) || + any(!is.finite(prepared$total_mvpa)) + ) { + stop( + "This workshop example requires complete support and MVPA observations.", + call. = FALSE + ) + } + + # 2. Keep the response-surface axes fixed for both outcome equations: + # X = the female partner's support + # Y = the male partner's support + # + # The actor and partner columns swap meaning across rows. These two lines + # undo that swap, so a male outcome is still modeled on the same X-Y axes + # as a female outcome. + model_data <- prepared |> + tibble::as_tibble() |> + dplyr::rename( + role = gender, + actor_support = .provided_support_actor, + partner_support = .provided_support_partner + ) |> + dplyr::mutate( + female_support = dplyr::if_else( + role == "female", + actor_support, + partner_support + ), + male_support = dplyr::if_else( + role == "male", + actor_support, + partner_support + ) + ) + + # Both partner predictors use one pooled centering constant. Therefore, + # X = Y still means that the two partners report the same amount of support. + support_center <- mean(model_data$actor_support) + + model_data <- model_data |> + dplyr::mutate( + female_support_c = female_support - support_center, + male_support_c = male_support - support_center, + female_support_sq = female_support_c^2, + support_product = female_support_c * male_support_c, + male_support_sq = male_support_c^2 + ) + + # 3. Fit both polynomial regressions in one double-intercept model. + # + # `role` selects one intercept and one set of five polynomial coefficients + # for each partner. With observation-level dispersion fixed near zero, the + # 2 x 2 unstructured dyad block represents the residual variances of female + # and male MVPA and their residual covariance. This is the multilevel + # equivalent of the joint Gaussian SEM used by Schönbrodt et al. (2018). + fit <- glmmTMB::glmmTMB( + total_mvpa ~ 0 + role + + role:( + female_support_c + + male_support_c + + female_support_sq + + support_product + + male_support_sq + ) + + us(0 + role | couple_id), + dispformula = ~0, + family = stats::gaussian(), + REML = FALSE, + na.action = stats::na.fail, + data = model_data + ) + + if ( + fit$fit$convergence != 0 || + !isTRUE(fit$sdr$pdHess) + ) { + stop( + "The joint dyadic response surface model did not converge cleanly.", + call. = FALSE + ) + } + + fixed_effects <- glmmTMB::fixef(fit)$cond + + fixed_effect <- function(term) { + estimate <- unname(fixed_effects[term]) + if (length(estimate) != 1 || !is.finite(estimate)) { + stop("Could not recover model coefficient `", term, "`.", call. = FALSE) + } + estimate + } + + # 4. Put the fitted coefficients into standard response-surface notation. + # The X and Y meanings do not change between the two outcome equations. + surface_coefficients <- list( + female = c( + b0 = fixed_effect("rolefemale"), + x = fixed_effect("rolefemale:female_support_c"), + y = fixed_effect("rolefemale:male_support_c"), + x2 = fixed_effect("rolefemale:female_support_sq"), + xy = fixed_effect("rolefemale:support_product"), + y2 = fixed_effect("rolefemale:male_support_sq") + ), + male = c( + b0 = fixed_effect("rolemale"), + x = fixed_effect("rolemale:female_support_c"), + y = fixed_effect("rolemale:male_support_c"), + x2 = fixed_effect("rolemale:female_support_sq"), + xy = fixed_effect("rolemale:support_product"), + y2 = fixed_effect("rolemale:male_support_sq") + ) + ) + + derive_surface_parameters <- function(coefficients) { + c( + # Slope and curvature along the line of congruence, X = Y. + a1 = coefficients[["x"]] + coefficients[["y"]], + a2 = coefficients[["x2"]] + coefficients[["xy"]] + + coefficients[["y2"]], + # Slope and curvature along the line of incongruence, X = -Y. + a3 = coefficients[["x"]] - coefficients[["y"]], + a4 = coefficients[["x2"]] - coefficients[["xy"]] + + coefficients[["y2"]], + # Difference between the female- and male-score squared terms. + a5 = coefficients[["x2"]] - coefficients[["y2"]] + ) + } + + female_surface <- derive_surface_parameters(surface_coefficients$female) + male_surface <- derive_surface_parameters(surface_coefficients$male) + surface_parameters <- c( + stats::setNames(female_surface, paste0(names(female_surface), "f")), + stats::setNames(male_surface, paste0(names(male_surface), "m")) + ) + + fitted_dyad_covariance <- as.matrix( + glmmTMB::VarCorr(fit)$cond$couple_id + ) + outcome_residual_covariance <- matrix( + as.numeric(fitted_dyad_covariance), + nrow = 2, + dimnames = list(c("female", "male"), c("female", "male")) + ) + diag(outcome_residual_covariance) <- + diag(outcome_residual_covariance) + stats::sigma(fit)^2 + residual_correlation <- + outcome_residual_covariance["female", "male"] / + sqrt( + outcome_residual_covariance["female", "female"] * + outcome_residual_covariance["male", "male"] + ) + + # For each outcome, R-squared compares the observed values with predictions + # from the fixed response surface. Excluding dyad effects is important here: + # their unstructured covariance is how this model represents residuals. + fixed_surface_prediction <- stats::predict( + fit, + re.form = NA, + type = "response" + ) + variance_explained <- function(observed, predicted) { + 1 - + sum((observed - predicted)^2) / + sum((observed - mean(observed))^2) + } + r2 <- c( + female_mvpa = variance_explained( + model_data$total_mvpa[model_data$role == "female"], + fixed_surface_prediction[model_data$role == "female"] + ), + male_mvpa = variance_explained( + model_data$total_mvpa[model_data$role == "male"], + fixed_surface_prediction[model_data$role == "male"] + ) + ) + + structure( + list( + fit = fit, + data = model_data, + support_center = support_center, + fixed_effects = fixed_effects, + residual_covariance = outcome_residual_covariance, + surface_parameters = surface_parameters, + surface_coefficients = surface_coefficients, + residual_correlation = residual_correlation, + r2 = r2 + ), + class = "workshop_drsa" + ) +} diff --git a/dev/workshop/R/fit-early-models.R b/dev/workshop/R/fit-early-models.R index 0249a576..3683b5a1 100644 --- a/dev/workshop/R/fit-early-models.R +++ b/dev/workshop/R/fit-early-models.R @@ -2,7 +2,7 @@ predictor <- rlang::as_name(predictor) outcome <- rlang::as_name(outcome) - required <- c("couple_id", "person_id", "role", predictor, outcome) + required <- c("couple_id", "person_id", "gender", predictor, outcome) missing <- setdiff(required, names(data)) if (length(missing)) { stop( @@ -25,20 +25,20 @@ } .fit_early_gaussian_model <- function(formula, data) { - model_environment <- new.env(parent = environment(formula)) - model_environment$.early_model_data <- data - environment(formula) <- model_environment + # Give the prepared data a stable name in this function environment. glmmTMB + # retains that environment with the fitted formula, allowing dyadMLM to + # recover the data later when two models are compared. + .early_model_data <- data model <- glmmTMB::glmmTMB( formula, dispformula = ~0, family = stats::gaussian(), - data = data + data = .early_model_data ) # Keep the evaluated formula in the returned call so formula(model) remains # available after this helper's local objects have gone out of scope. model$call$formula <- formula - model$call$data <- quote(.early_model_data) model } @@ -48,7 +48,7 @@ data, dyad = couple_id, member = person_id, - role = role, + role = gender, predictors = !!rlang::sym(predictor), model_types = model_types, dsm_role_order = if (identical(model_types, "dsm")) { @@ -61,6 +61,28 @@ ) } +.grand_mean_center_apim_predictors <- function(data, predictor) { + actor <- paste0(".", predictor, "_actor") + partner <- paste0(".", predictor, "_partner") + complete_pair <- is.finite(data[[actor]]) & is.finite(data[[partner]]) + + if (!any(complete_pair)) { + stop( + "No complete actor-partner predictor pairs are available for centering.", + call. = FALSE + ) + } + + # One common centering constant preserves female-male differences and matches + # the grand mean used for the DIM/DSM dyad-mean predictor. + grand_mean <- mean( + (data[[actor]][complete_pair] + data[[partner]][complete_pair]) / 2 + ) + data[[actor]] <- data[[actor]] - grand_mean + data[[partner]] <- data[[partner]] - grand_mean + data +} + # Each public helper draws the fitted diagram and invisibly returns its model. fit_and_draw_distinguishable_apim <- function( @@ -71,24 +93,34 @@ fit_and_draw_distinguishable_apim <- function( prepared <- .prepare_early_model_data( data, variables$predictor, model_types = "apim" ) + prepared <- .grand_mean_center_apim_predictors( + prepared, variables$predictor + ) - actor <- paste0(".dy_", variables$predictor, "_actor") - partner <- paste0(".dy_", variables$predictor, "_partner") - female <- ".dy_is_female_x_male_female" - male <- ".dy_is_female_x_male_male" + actor <- paste0(".", variables$predictor, "_actor") + partner <- paste0(".", variables$predictor, "_partner") + female_indicator <- ".is_female" + male_indicator <- ".is_male" model_formula <- .early_model_formula( variables$outcome, c( - "0", female, male, - paste0(female, ":", actor), paste0(male, ":", actor), - paste0(female, ":", partner), paste0(male, ":", partner), - paste0("us(0 + ", female, " + ", male, " | couple_id)") + "0", female_indicator, male_indicator, + paste0(female_indicator, ":", actor), + paste0(male_indicator, ":", actor), + paste0(female_indicator, ":", partner), + paste0(male_indicator, ":", partner), + paste0( + "us(0 + ", female_indicator, " + ", male_indicator, " | couple_id)" + ) ) ) model <- .fit_early_gaussian_model(model_formula, prepared) - draw_apim_diagram("distinguishable", model = model, labels = labels) + draw_apim_diagram( + "distinguishable", model = model, labels = labels, + predictors_centered = TRUE + ) invisible(model) } @@ -100,23 +132,29 @@ fit_and_draw_exchangeable_apim <- function( prepared <- .prepare_early_model_data( data, variables$predictor, model_types = "apim", exchangeable = TRUE ) + prepared <- .grand_mean_center_apim_predictors( + prepared, variables$predictor + ) - actor <- paste0(".dy_", variables$predictor, "_actor") - partner <- paste0(".dy_", variables$predictor, "_partner") - intercept <- ".dy_is_female_x_male" - difference <- ".dy_member_contrast_female_x_male_arbitrary" + actor <- paste0(".", variables$predictor, "_actor") + partner <- paste0(".", variables$predictor, "_partner") + exchangeable_indicator <- ".is_exchangeable" + member_contrast <- ".member_contrast_arbitrary" model_formula <- .early_model_formula( variables$outcome, c( - "0", intercept, actor, partner, - paste0("us(0 + ", intercept, " | couple_id)"), - paste0("us(0 + ", difference, " | couple_id)") + "0", exchangeable_indicator, actor, partner, + paste0("us(0 + ", exchangeable_indicator, " | couple_id)"), + paste0("us(0 + ", member_contrast, " | couple_id)") ) ) model <- .fit_early_gaussian_model(model_formula, prepared) - draw_apim_diagram("exchangeable", model = model, labels = labels) + draw_apim_diagram( + "exchangeable", model = model, labels = labels, + predictors_centered = TRUE + ) invisible(model) } @@ -128,15 +166,15 @@ fit_and_draw_dim <- function(data, predictor, outcome, labels = NULL) { data, variables$predictor, model_types = "dim", exchangeable = TRUE ) - mean <- paste0(".dy_", variables$predictor, "_dyad_mean_gmc") - deviation <- paste0(".dy_", variables$predictor, "_within_dyad_dev") - difference <- ".dy_member_contrast_female_x_male_arbitrary" + dyad_mean <- paste0(".", variables$predictor, "_dyad_mean_gmc") + member_deviation <- paste0(".", variables$predictor, "_within_dyad_dev") + member_contrast <- ".member_contrast_arbitrary" model_formula <- .early_model_formula( variables$outcome, c( - "1", mean, deviation, "us(1 | couple_id)", - paste0("us(0 + ", difference, " | couple_id)") + "1", dyad_mean, member_deviation, "us(1 | couple_id)", + paste0("us(0 + ", member_contrast, " | couple_id)") ) ) model <- .fit_early_gaussian_model(model_formula, prepared) @@ -153,9 +191,9 @@ fit_and_draw_dsm <- function(data, predictor, outcome, labels = NULL) { data, variables$predictor, model_types = "dsm" ) - mean <- paste0(".dy_", variables$predictor, "_dyad_mean_gmc") - difference <- paste0(".dy_", variables$predictor, "_within_dyad_diff") - role <- ".dy_dsm_role_contrast" + mean <- paste0(".", variables$predictor, "_dyad_mean_gmc") + difference <- paste0(".", variables$predictor, "_within_dyad_diff") + role <- ".dsm_role_contrast" model_formula <- .early_model_formula( variables$outcome, diff --git a/dev/workshop/R/fit-truth-bias.R b/dev/workshop/R/fit-truth-bias.R new file mode 100644 index 00000000..b3c167a4 --- /dev/null +++ b/dev/workshop/R/fit-truth-bias.R @@ -0,0 +1,225 @@ +fit_truth_bias <- function(data) { + required_columns <- c( + "couple_id", "person_id", "gender", + "provided_support", "received_support" + ) + missing_columns <- setdiff(required_columns, names(data)) + + if (length(missing_columns)) { + stop( + "The workshop data is missing: ", + paste(missing_columns, collapse = ", "), + call. = FALSE + ) + } + + if ( + !is.numeric(data$provided_support) || + !is.numeric(data$received_support) + ) { + stop( + "`provided_support` and `received_support` ", + "must be numeric.", + call. = FALSE + ) + } + + # Each row is a perceiver. The perceiver's received-support report is the + # judgment, their own provided support is the assumed-similarity predictor, + # and their partner's provided support is the operational truth criterion. + prepared <- dyadMLM::prepare_dyad_data( + data, + dyad = couple_id, + member = person_id, + role = gender, + predictors = provided_support, + model_types = "apim", + keep_compositions = "female-male" + ) + + model_data <- prepared |> + tibble::as_tibble() |> + dplyr::rename( + role = gender, + own_provided_support = .provided_support_actor, + partner_provided_support = .provided_support_partner + ) + + analysis_columns <- c( + "provided_support", "received_support", + "own_provided_support", "partner_provided_support" + ) + columns_are_complete <- vapply( + model_data[analysis_columns], + function(variable) all(is.finite(variable)), + logical(1) + ) + if (!all(columns_are_complete)) { + stop( + "This workshop example requires complete provided- and received-support ", + "observations for both partners.", + call. = FALSE + ) + } + + dyad_sizes <- dplyr::count(model_data, couple_id, name = "members") + if (any(dyad_sizes$members != 2L)) { + stop( + "This workshop example requires exactly two observations per couple.", + call. = FALSE + ) + } + + # West and Kenny's centering is essential for the intercept interpretation: + # subtract the same pooled truth mean from the judgment (J), truth predictor + # (T), and bias predictor (B). Do not center received support on its own mean. + truth_mean <- mean(model_data$provided_support) + + model_data <- model_data |> + dplyr::mutate( + received_support_c = received_support - truth_mean, + own_provided_support_c = own_provided_support - truth_mean, + partner_provided_support_c = partner_provided_support - truth_mean + ) + + # This is the distinguishable cross-sectional Truth and Bias model written as + # one double-intercept multilevel model. The unstructured dyad block supplies + # the two judgment-residual variances and their covariance; it is not a + # substantive random-intercept process in this two-row-per-couple example. + fit <- glmmTMB::glmmTMB( + received_support_c ~ 0 + role + + role:own_provided_support_c + + role:partner_provided_support_c + + us(0 + role | couple_id), + dispformula = ~0, + family = stats::gaussian(), + REML = FALSE, + na.action = stats::na.fail, + data = model_data + ) + + if (fit$fit$convergence != 0 || !isTRUE(fit$sdr$pdHess)) { + stop( + "The cross-sectional Truth and Bias model did not converge cleanly.", + call. = FALSE + ) + } + + coefficient_table <- summary(fit)$coefficients$cond + + coefficient_value <- function(term, column) { + value <- coefficient_table[term, column] + if (length(value) != 1L || !is.finite(value)) { + stop( + "Could not recover `", column, "` for model term `", term, "`.", + call. = FALSE + ) + } + unname(value) + } + + fixed_terms <- c( + intercept_female = "rolefemale", + intercept_male = "rolemale", + bias_female = "rolefemale:own_provided_support_c", + bias_male = "rolemale:own_provided_support_c", + truth_female = "rolefemale:partner_provided_support_c", + truth_male = "rolemale:partner_provided_support_c" + ) + estimates <- vapply( + fixed_terms, + coefficient_value, + numeric(1), + column = "Estimate" + ) + p_values <- vapply( + fixed_terms, + coefficient_value, + numeric(1), + column = "Pr(>|z|)" + ) + + # glmmTMB conditions on the predictors, so actual similarity is calculated + # once per couple as the raw correlation between partners' provided support. + provided_support_by_role <- model_data |> + dplyr::select(couple_id, role, provided_support) |> + tidyr::pivot_wider( + names_from = role, + values_from = provided_support + ) + actual_similarity_test <- stats::cor.test( + provided_support_by_role$female, + provided_support_by_role$male, + method = "pearson" + ) + + # The correlation describes actual similarity, but the indirect-accuracy + # decomposition needs an unstandardized path a. Its direction differs by + # perceiver: the perceiver's own provision (B) is regressed on the partner's + # provision (T). Indirect accuracy is a * b; total accuracy is t + a * b. + actual_similarity_paths <- c( + female = unname(stats::coef(stats::lm( + female ~ male, + data = provided_support_by_role + ))[["male"]]), + male = unname(stats::coef(stats::lm( + male ~ female, + data = provided_support_by_role + ))[["female"]]) + ) + indirect_accuracy <- c( + female = actual_similarity_paths[["female"]] * + estimates[["bias_female"]], + male = actual_similarity_paths[["male"]] * estimates[["bias_male"]] + ) + total_accuracy <- c( + female = estimates[["truth_female"]] + indirect_accuracy[["female"]], + male = estimates[["truth_male"]] + indirect_accuracy[["male"]] + ) + + fitted_dyad_covariance <- as.matrix( + glmmTMB::VarCorr(fit)$cond$couple_id + ) + role_terms <- c(female = "rolefemale", male = "rolemale") + outcome_residual_covariance <- fitted_dyad_covariance[ + role_terms, role_terms, drop = FALSE + ] + dimnames(outcome_residual_covariance) <- list( + names(role_terms), names(role_terms) + ) + diag(outcome_residual_covariance) <- + diag(outcome_residual_covariance) + stats::sigma(fit)^2 + + residuals <- c( + sd_female = sqrt(outcome_residual_covariance["female", "female"]), + sd_male = sqrt(outcome_residual_covariance["male", "male"]), + correlation = outcome_residual_covariance["female", "male"] / + sqrt( + outcome_residual_covariance["female", "female"] * + outcome_residual_covariance["male", "male"] + ) + ) + + structure( + list( + fit = fit, + data = model_data, + truth_mean = truth_mean, + n_dyads = nrow(provided_support_by_role), + estimates = estimates, + p_values = p_values, + residuals = residuals, + residual_covariance = outcome_residual_covariance, + actual_similarity_paths = actual_similarity_paths, + indirect_accuracy = indirect_accuracy, + total_accuracy = total_accuracy, + actual_similarity = c( + estimate = unname(actual_similarity_test$estimate), + p_value = actual_similarity_test$p.value, + conf_low = actual_similarity_test$conf.int[[1]], + conf_high = actual_similarity_test$conf.int[[2]] + ) + ), + class = "workshop_truth_bias" + ) +} diff --git a/dev/workshop/R/generate-ild-exercise-data.R b/dev/workshop/R/generate-ild-exercise-data.R new file mode 100644 index 00000000..e51576ee --- /dev/null +++ b/dev/workshop/R/generate-ild-exercise-data.R @@ -0,0 +1,330 @@ +# Generate the focused ILD dataset used in 04_exercises_ild.Rmd. +# +# The predictor is generated first. The outcome is then simulated from the +# exact distinguishable glmmTMB formula taught in the exercise, including +# role-specific AR(1) processes and same-occasion partner covariance. +# +# glmmTMB::simulate_new() is experimental. This script was generated and +# stress-tested with glmmTMB 1.1.14; the named parameter order and checks below +# are intended to make any future API drift visible before the RDS is replaced. + +make_ild_exercise_predictor_data <- function( + seed, + n_dyads = 120L, + diary_days = 0:13) { + stopifnot( + length(seed) == 1L, + length(n_dyads) == 1L, + n_dyads >= 2L, + identical(diary_days, 0:13) + ) + + set.seed(seed) + + panel <- expand.grid( + member_position = 1:2, + diaryday = diary_days, + coupleID = seq_len(n_dyads), + KEEP.OUT.ATTRS = FALSE + ) + panel <- panel[order( + panel$coupleID, + panel$diaryday, + panel$member_position + ), ] + + panel$personID <- 2L * panel$coupleID - 2L + panel$member_position + panel$gender <- factor( + ifelse(panel$member_position == 1L, "female", "male"), + levels = c("female", "male") + ) + panel$dyad_composition <- factor( + "female_x_male", + levels = "female_x_male" + ) + + support_shared_mean <- stats::rnorm(n_dyads, 0, 0.65) + support_difference_mean <- stats::rnorm(n_dyads, 0, 0.50) + + dyad_days <- expand.grid( + diaryday = diary_days, + coupleID = seq_len(n_dyads), + KEEP.OUT.ATTRS = FALSE + ) + dyad_days <- dyad_days[order( + dyad_days$coupleID, + dyad_days$diaryday + ), ] + support_shared_day <- stats::rnorm(nrow(dyad_days), 0, 0.50) + support_difference_day <- stats::rnorm(nrow(dyad_days), 0, 0.45) + + dyad_day_index <- match( + paste(panel$coupleID, panel$diaryday), + paste(dyad_days$coupleID, dyad_days$diaryday) + ) + member_sign <- ifelse(panel$gender == "female", 1, -1) + role_mean <- ifelse(panel$gender == "female", 5.15, 4.75) + + panel$provided_support <- + role_mean + + support_shared_mean[panel$coupleID] + + member_sign * support_difference_mean[panel$coupleID] + + support_shared_day[dyad_day_index] + + member_sign * support_difference_day[dyad_day_index] + + # simulate_new() requires the raw outcome column to exist in newdata. Its + # placeholder values are replaced below. + panel$closeness <- 0 + + panel <- panel[, c( + "personID", + "coupleID", + "diaryday", + "gender", + "dyad_composition", + "closeness", + "provided_support" + )] + + tibble::as_tibble(panel) +} + +prepare_ild_exercise_simulation_data <- function(data) { + prepared_data <- dyadMLM::prepare_dyad_data( + data = data, + dyad = coupleID, + member = personID, + role = gender, + time = diaryday, + predictors = provided_support, + model_types = "apim", + temporal_decomposition = "2l" + ) + + prepared_data$diaryday_c <- (prepared_data$diaryday - 6.5) / 13 + prepared_data$diaryday_f <- factor( + prepared_data$diaryday, + levels = 0:13 + ) + + prepared_data +} + +ild_exercise_fixed_formula <- ~ + 0 + .is_female + .is_male + + .is_female:diaryday_c + + .is_male:diaryday_c + + .is_female:.provided_support_cwp_actor + + .is_male:.provided_support_cwp_actor + + .is_female:.provided_support_cwp_partner + + .is_male:.provided_support_cwp_partner + + .is_female:.provided_support_cbp_actor + + .is_male:.provided_support_cbp_actor + + .is_female:.provided_support_cbp_partner + + .is_male:.provided_support_cbp_partner + +ild_exercise_simulation_formula <- update( + ild_exercise_fixed_formula, + ~ . + + (0 + .is_female + .is_male | coupleID) + + ar1(0 + .is_female:diaryday_f | coupleID) + + ar1(0 + .is_male:diaryday_f | coupleID) + + (0 + .is_female + .is_male | coupleID:diaryday) +) + +ild_exercise_fixed_effects <- c( + ".is_female" = 5.30, + ".is_male" = 4.80, + ".is_female:diaryday_c" = -0.18, + ".is_male:diaryday_c" = 0.10, + ".is_female:.provided_support_cwp_actor" = 0.45, + ".is_male:.provided_support_cwp_actor" = 0.25, + ".is_female:.provided_support_cwp_partner" = 0.20, + ".is_male:.provided_support_cwp_partner" = 0.08, + ".is_female:.provided_support_cbp_actor" = 0.80, + ".is_male:.provided_support_cbp_actor" = 0.55, + ".is_female:.provided_support_cbp_partner" = 0.30, + ".is_male:.provided_support_cbp_partner" = 0.15 +) + +# glmmTMB theta parameters follow the random-term order in the formula: +# stable role covariance (3), female AR(1) (2), male AR(1) (2), and +# same-occasion role covariance (3). +ild_exercise_theta <- c( + "stable_log_sd_female" = log(0.65), + "stable_log_sd_male" = log(0.50), + "stable_correlation" = glmmTMB::put_cor(0.35, input_val = "vec"), + "female_ar1_log_sd" = log(0.80), + "female_ar1_correlation" = glmmTMB::put_cor( + 0.70, + input_val = "vec" + ), + "male_ar1_log_sd" = log(0.60), + "male_ar1_correlation" = glmmTMB::put_cor( + 0.45, + input_val = "vec" + ), + "same_day_log_sd_female" = log(0.40), + "same_day_log_sd_male" = log(0.45), + "same_day_correlation" = glmmTMB::put_cor(0.25, input_val = "vec") +) + +check_ild_exercise_model_structure <- function(prepared_data) { + fitting_formula <- update( + ild_exercise_simulation_formula, + closeness ~ . + ) + model_structure <- glmmTMB::glmmTMB( + formula = fitting_formula, + dispformula = ~ 0, + family = gaussian(), + data = prepared_data, + doFit = FALSE + ) + + random_structure <- model_structure$condReStruc + expected_terms <- c( + "0 + .is_female + .is_male | coupleID", + "0 + .is_female:diaryday_f | coupleID", + "0 + .is_male:diaryday_f | coupleID", + "0 + .is_female + .is_male | coupleID:diaryday" + ) + expected_covariance_types <- c("us", "ar1", "ar1", "us") + expected_theta_counts <- c(3, 2, 2, 3) + + stopifnot( + identical(names(random_structure), expected_terms), + identical( + unname(vapply( + random_structure, + function(term) names(term$blockCode), + character(1) + )), + expected_covariance_types + ), + identical( + as.double(vapply( + random_structure, + function(term) term$blockNumTheta, + numeric(1) + )), + expected_theta_counts + ), + length(model_structure$parameters$theta) == + length(ild_exercise_theta) + ) + + invisible(model_structure) +} + +# Seed 20260719 was selected after checking 20260719:20260721 with the exact +# workshop full and pooled models; both candidates converged for all three. +# The selected seed had interior covariance estimates, recovered the intended +# role-specific AR(1) pattern clearly, and reached the same optimum from three +# starting values. +simulate_ild_exercise_data <- function( + seed = 20260719L, + n_dyads = 120L) { + installed_glmmTMB <- as.character(utils::packageVersion("glmmTMB")) + if (!identical(installed_glmmTMB, "1.1.14")) { + warning( + "This generator was stress-tested with glmmTMB 1.1.14, not ", + installed_glmmTMB, + ". Recheck the fixed-effect and theta parameter order before replacing ", + "the workshop RDS.", + call. = FALSE + ) + } + + raw_data <- make_ild_exercise_predictor_data( + seed = seed, + n_dyads = n_dyads + ) + prepared_data <- prepare_ild_exercise_simulation_data( + data = raw_data + ) + + raw_row_keys <- paste( + raw_data$coupleID, + raw_data$personID, + raw_data$diaryday + ) + prepared_row_keys <- paste( + prepared_data$coupleID, + prepared_data$personID, + prepared_data$diaryday + ) + stopifnot(identical(raw_row_keys, prepared_row_keys)) + + fixed_columns <- colnames(stats::model.matrix( + ild_exercise_fixed_formula, + data = prepared_data + )) + stopifnot(identical(fixed_columns, names(ild_exercise_fixed_effects))) + check_ild_exercise_model_structure(prepared_data) + + simulated_outcome <- glmmTMB::simulate_new( + object = ild_exercise_simulation_formula, + nsim = 1, + seed = seed + 100000L, + family = gaussian(), + newdata = prepared_data, + newparams = list( + beta = unname(ild_exercise_fixed_effects), + theta = unname(ild_exercise_theta) + ), + dispformula = ~ 0 + ) + + raw_data$closeness <- as.double(simulated_outcome[[1L]]) + raw_data +} + +check_ild_exercise_data <- function(data, n_dyads = 120L) { + stopifnot( + identical( + names(data), + c( + "personID", + "coupleID", + "diaryday", + "gender", + "dyad_composition", + "closeness", + "provided_support" + ) + ), + nrow(data) == n_dyads * 2L * 14L, + dplyr::n_distinct(data$coupleID) == n_dyads, + dplyr::n_distinct(data$personID) == 2L * n_dyads, + identical(levels(data$gender), c("female", "male")), + identical(levels(data$dyad_composition), "female_x_male"), + identical(sort(unique(data$diaryday)), 0:13), + !anyDuplicated(data[c("coupleID", "personID", "diaryday")]), + all(table(data$coupleID, data$diaryday) == 2L), + all(is.finite(data$closeness)), + all(is.finite(data$provided_support)) + ) + + invisible(data) +} + +if (sys.nframe() == 0L) { + workshop_dir <- if (dir.exists(file.path("dev", "workshop"))) { + file.path("dev", "workshop") + } else { + "." + } + + output_file <- file.path(workshop_dir, "dyadic-ild-exercise.rds") + ild_exercise_data <- simulate_ild_exercise_data() + check_ild_exercise_data(ild_exercise_data) + saveRDS(ild_exercise_data, output_file) + + message( + "Saved ", + nrow(ild_exercise_data), + " rows to ", + normalizePath(output_file) + ) +} diff --git a/dev/workshop/applied-tutorial.html b/dev/workshop/applied-tutorial.html deleted file mode 100644 index 850c2d5d..00000000 --- a/dev/workshop/applied-tutorial.html +++ /dev/null @@ -1,3125 +0,0 @@ - - - - - - - - - - - - - - Dyadic Data Analysis with R - - - - - - - - - - - - - - - -
-
- -
-

Dyadic Data Analysis with R

-

Part II: Applied Tutorial

- -
-
-
-Pascal Küng -
-
-
-
-Turu Stadler -
-
-
- -
-
-

Applied tutorial

-

Content in development.

- -
-
-
- - - - - - - - - - - - - - - - - - -
- Universität Zürich - - Charité – Universitätsmedizin Berlin -
-
Summer School 2026
- - - - \ No newline at end of file diff --git a/dev/workshop/applied-tutorial.qmd b/dev/workshop/applied-tutorial.qmd index 2f1bcc6c..0c46e190 100644 --- a/dev/workshop/applied-tutorial.qmd +++ b/dev/workshop/applied-tutorial.qmd @@ -4,6 +4,8 @@ subtitle: "Part II: Applied Tutorial" author: - "Pascal Küng" - "Turu Stadler" +bibliography: ../../vignettes/references.bib +csl: apa.csl resources: - uzh-logo.svg - charite-logo.svg @@ -23,6 +25,2532 @@ execute: editor: source --- -## Applied tutorial +```{r} +#| label: setup-applied-tutorial +#| include: false -Content in development. +library(dplyr) +library(ggplot2) + +slide_table <- function(x, digits = 2, ...) { + knitr::kable( + x, + format = "html", + digits = digits, + format.args = list( + nsmall = digits, + scientific = FALSE + ), + row.names = FALSE, + ... + ) +} + +diagram_helper_candidates <- c( + "diagram-helpers.Rinc", + file.path("vignettes", "diagram-helpers.Rinc"), + file.path("..", "..", "vignettes", "diagram-helpers.Rinc") +) +diagram_helper <- diagram_helper_candidates[ + file.exists(diagram_helper_candidates) +][1] + +if (is.na(diagram_helper)) { + stop("Could not find vignettes/diagram-helpers.Rinc.") +} + +sys.source( + normalizePath(diagram_helper), + envir = knitr::knit_global() +) + +sys.source( + "helpers.R", + envir = knitr::knit_global() +) + +refit_glmmTMB_with_bfgs_if_needed <- function(model) { + fit_converged <- isTRUE(model$fit$convergence == 0) + hessian_ok <- !identical(model$sdr$pdHess, FALSE) + if (fit_converged && hessian_ok) { + return(model) + } + + fitted_parameters <- model$fit$par + start_values <- list( + beta = unname(fitted_parameters[names(fitted_parameters) == "beta"]), + theta = unname(fitted_parameters[names(fitted_parameters) == "theta"]) + ) + + update( + model, + start = start_values, + control = glmmTMB::glmmTMBControl( + optimizer = stats::optim, + optArgs = list(method = "BFGS"), + optCtrl = list(maxit = 1000, reltol = 1e-10) + ) + ) +} + +``` + +## Today's aims and program + +::: {.fancy-table} + +| Time | Focus | +|---|---| +| [11:00–12:45]{.agenda-completed} | [Introduction and types of dyadic models]{.agenda-completed} | +| [12:45–14:00]{.agenda-completed} | [*Lunch break*]{.agenda-completed} | +| 14:00–15:30 | Cross-sectional APIM in R | +| 15:30–15:45 | *Short break* | +| 15:45–16:45 | Intensive longitudinal APIM in R | +| 16:45–17:00 | *Short break* | +| 17:00–18:00 | Exercises in R | + +::: + + + +# Software and frameworks + +## SEM vs. MLM {.smaller} + +- Many simple dyadic models can be represented in either framework. +- The best framework is the one that represents your conceptual model most naturally [@ledermannAnalyzingDyadicData2017]. + +:::: {.columns .fragment} + +::: {.column width="50%"} + +**SEM / DSEM is often more natural for** + +- Latent dyadic constructs (e.g., a CFM) +- Item-level measurement models for reflective measures +- Linked outcomes or equations [e.g., mediation; @ledermannMediationDyadicData2009] +- Short dynamic panels in wide-format [e.g., LD-APIM; @gistelinckMultilevelAutoregressiveSmall2021] +- Intensive lagged or coupled dynamics via DSEM/RDSEM [e.g., @asparouhovDynamicStructuralEquation2018] + +::: + +::: {.column width="50%"} + +**MLM is often more natural for** + +- Parsimonious observed-variable models with modest numbers of dyads +- Nested grouping and flexible random-effect structures +- Observed-outcome growth or concurrent ILD models with flexible time trends +- Complex observed-variable regressions—interactions, polynomials, splines, + and dyadic RSA—especially with repeated measures or additional nesting +- Specialized generalized mixed models in R, including zero-inflated, hurdle, + and Tweedie models + +::: + +:::: + +::: {.subtle} +[@asparouhovDynamicStructuralEquation2018; +@asparouhovComparisonModelsAnalysis2020; +@driverContinuousTimeStructural2017; +@gistelinckMultilevelAutoregressiveSmall2021; +@delrosarioPracticalGuideSpecifying2025; +@schonbrodtTestingSimilarityEffects2018; +@nestlerResponseSurfaceAnalysis2019; +@brooksGlmmTMBBalancesSpeed2017] +::: + +## SEM vs. MLM: Missing data {.smaller} + +:::{.fragment} +- **MLM: Complete-case** + - **Outcome missing:** Valid under MAR, MLM uses remaining observations + - **Predictor missing:** Valid under MAR, if missingness does **not depend** on the outcome after accounting for predictors + +::: + +:::{.fragment} +- **SEM with FIML and joint likelihood** + - Valid under MAR: Models predictors and outcomes jointly + +::: + +:::{.fragment} +- **MI: Imputation** + - Handles missing outcomes, predictors, and auxiliary information + - Must match the analysis and preserve person, dyad, role, and time structure + +::: + +::: {.fragment} +Include important predictors of missingness and missing values. FIML and MI +cover more MAR situations than row omission; none automatically solves MNAR. + +::: + +[@ledermannAnalyzingDyadicData2017; @hughesAccountingMissingData2019; @grundMultipleImputationMissing2018]{.subtle} + + + +## Why R {.smaller} + +:::: {.columns} + +::: {.column width="46%"} + +### Why we teach R + +:::{.fragment} +- **Free to use:** no license fees or institutional access barriers +- **Open source:** statistical implementations can be inspected, audited, and adapted +- **Reproducible:** workflows can be rerun, reviewed, shared, and version-controlled +- **Extensible:** specialized methods integrate with data, graphics, and reporting +::: + +::: + +::: {.column width="54%"} + +### Current trade-offs + +:::{.fragment} + +- **SEM/DSEM:** R spreads these capabilities across specialized packages + - `lavaan`: fixed-wave and limited two-level SEM + - `mlts` and `ctsem`: multivariate dynamic models + - Dyadic DSEM in R remains cumbersome and limited + - Mplus remains the most complete (non-open) option with DSEM capabilities +- **MLM/ILD:** `glmmTMB` and `brms` both model serial dependence + - Neither directly offers a separable partner-by-time residual structure such + as $\mathrm{UN}\otimes\mathrm{AR}(1)$ + - SAS `PROC MIXED` and SPSS `MIXED` do for Gaussian repeated-measures models + +::: + +::: + +:::: + +::: {.subtle} +[@lavaanMultilevelSEM; +@mulderThreeExtensions2021; +@blavaanTwoLevelSEM; +@koslowskiMlts2025; +@driverContinuousTimeStructural2017; +@asparouhovDynamicStructuralEquation2018; +@asparouhovComparisonModelsAnalysis2020; +@kristensenCovarianceStructuresGlmmTMB2023; +@buerknerAutocorrelationStructuresBrms; +@sasInstituteMixedProcedure; +@ibmCovarianceStructureList] +::: + + + +# Cross-sectional APIM in R + +## One possible workflow + +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability (if applicable), and robustness** +6. **Visualize, interpret, and report results** + +::: {.subtle} +Synthesized from @kenny2006dyadic, @ledermannToolboxProgramsRestructure2015, and @stasGivingDyadicData2018. +::: + +:::{.notes} + +- In this example we will use the same dataset that we already used in Part I + +::: + +## One possible workflow + +1. [**Define dyads, distinguishability, and research questions**]{.text-highlight} +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability (if applicable), and robustness** +6. **Visualize, interpret, and report results** + +::: {.subtle} +Synthesized from @kenny2006dyadic, @ledermannToolboxProgramsRestructure2015, and @stasGivingDyadicData2018. +::: + + +## The Dataset + +**Same as before: ** + +- 36 physically inactive romantic couples +- Both partners intended to become more physically active +- Smartphone-based planning interventions and JITAIs +- Daily diaries over 55 days + +**Aggregated for cross-sectional analyses** + + +## Research Question {.rq-slide} + +::: {.rq-center} +::: {.rq-card} +[RQ:]{.rq-label} [In romantic couples, is a person's **self-efficacy** linked to physical activity in both partners?]{.rq-text} +::: +::: + +## Measurement - predictor + +### Self-efficacy + +> **Rough English translation of the original German item**
+> “I am confident that I can be physically active tomorrow, even if it becomes +> difficult.” +> +> [Adapted from @sniehottaBridgingIntentionBehaviour2005]{.subtle} + +0 = *not at all true today*
+5 = *completely true today*
+ + + +## Measurement - outcome + +### Moderate to vigorous physical activity (MVPA) + +> **Rough English translation of the original German item**
+> “How many minutes did you spend engaging in moderate-to-vigorous physical +> activity today?” +> +> [Adapted from @amireaultGodinShephardQuestionnaire2015]{.subtle} + +- **Alone:** _____ minutes +- **Together with your partner:** _____ minutes + +**Total MVPA = solo MVPA + joint MVPA.** + + + +# Distinguishable dyads +Distinguishing by gender + +:::{.notes} + +-> Gender, but TEST! + +::: + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. [**Prepare the data and validate the dyadic structure**]{.text-highlight} +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## Load and inspect the raw data + +```{r} +library(dplyr) # for easier data-wrangling, exports functions like `select()` + +raw_dyad_data <- readRDS("dyadic-person-means.rds") |> + dplyr::select( + couple_id, person_id, gender, efficacy, total_mvpa + ) + +# usually use head(raw_dyad_data), slide_table is a custom function for html tables on these slides +slide_table(raw_dyad_data[1:4,]) +``` + +:::{.subtle} + +
+ +This dataset is stored as an R object. Other packages provide functions to import various formats, such as: `readxl::read_excel()`, `utils::read.csv()`, `haven::read_sav()`, `haven::read_sas()` + +::: + +:::{.notes} + +Manual inspection at each step is important! + +Example that Lilly told me: weird associations, until discovered that +missing values were coded as 99, in a software that didn't recognize this +as a missing value. + +::: + +## Create the required format and validate the data + +**For the distinguishable APIM we need to add:** + +- `efficacy_actor` and `efficacy_partner` columns +- Dummy coded numeric variables for the two roles + +:::{.fragment} +**Validate things like: ** + +- no dyad with more than two members, +- each dyad-member combination occurs only once (per occasion), +- gender labels are present and consistent +- you only have the type of dyad you expect +::: + +## Create the required format and validate the data + +We can use the `dyadMLM` package to help with data preparation and validation. + +```{r} +#| output-location: slide + +library(dyadMLM) + +apim_distinguishable_data <- dyadMLM::prepare_dyad_data( # exported function from dyadMLM + data = raw_dyad_data, + dyad = couple_id, + member = person_id, + role = gender, + predictors = efficacy, + model_types = 'apim', + # if we want to fit an exchangeable model from the same data we can: + include_arbitrary_member_contrast = TRUE, + add_apim_gmc_predictors = TRUE, + seed = 123 +) + +print(apim_distinguishable_data) + +``` + + +## Create the required format and validate the data [Manual code →](#manual-apim-preparation){.results-forward-link} {#prepared-apim-data} + +Looking at the columns immediately relevant to us: + +```{r} + +head(apim_distinguishable_data) |> + dplyr::select( + couple_id, person_id, gender, .is_female, .is_male, .efficacy_gmc, .efficacy_gmc_actor, .efficacy_gmc_partner, total_mvpa + ) |> + slide_table() + +``` + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. [**Describe and visualize measures and observed relationships**]{.text-highlight} +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## Create a wide view for role-specific exploration + +The models will **NOT** use this dataset + +```{r} +apim_distinguishable_wide_data <- apim_distinguishable_data |> + dplyr::select(couple_id, gender, efficacy, total_mvpa) |> + tidyr::pivot_wider( + names_from = gender, + values_from = c(efficacy, total_mvpa) + ) + +slide_table(head(apim_distinguishable_wide_data)) +``` + + +## Describe focal variables per role + +```{r} +library(report) + +apim_distinguishable_wide_data |> + dplyr::select(-couple_id) |> + report::report_table() |> + slide_table() +``` + +## Visualize focal variable by partner role + +```{r} + +library(ggplot2) +library(see) + +plot_role_histograms <- function(data, group, var) { + var_label <- rlang::as_label(rlang::enquo(var)) + + ggplot( + data, + aes(x = {{ var }}, y = after_stat(density)) + ) + + geom_histogram( + bins = 15, boundary = 0, + fill = "steelblue", color = "white", alpha = 0.75 + ) + + geom_density( + bounds = c(0, Inf), color = "navy", linewidth = 1.1 + ) + + facet_wrap(vars({{ group }}), nrow = 1) + + labs(x = var_label, y = "Density") + + see::theme_modern(base_size = 16) +} + +``` + +## Visualize focal variable by partner role - Efficacy + +```{r} +#| dev: svglite + +plot_role_histograms(apim_distinguishable_data, gender, efficacy) +``` + + +## Visualize focal variable by partner role - MVPA + +```{r} +#| dev: svglite + +plot_role_histograms(apim_distinguishable_data, gender, total_mvpa) +``` + +## Observed dyadic correlations + +The wide data ensure that each couple contributes once. + +```{r} +library(correlation) +library(insight) + +apim_distinguishable_wide_data |> + correlation::correlation( + select = c("efficacy_female", "total_mvpa_female"), + select2 = c("efficacy_male", "total_mvpa_male") + ) |> + summary() |> + insight::print_md(footer = "") +``` + + +## Visualize partner similarity + +```{r} +plot_partner_similarity <- function(data, x, y, id, title, n_mahalanobis = 3) { + x_name <- rlang::as_name(rlang::enquo(x)) + y_name <- rlang::as_name(rlang::enquo(y)) + xy <- cbind(data[[x_name]], data[[y_name]]) + labels <- data |> + dplyr::mutate( + .distance = mahalanobis(xy, colMeans(xy), cov(xy)) + ) |> + dplyr::distinct({{ id }}, .keep_all = TRUE) |> + dplyr::slice_max(.distance, n = n_mahalanobis, with_ties = FALSE) + + ggplot(data, aes(x = {{ x }}, y = {{ y }})) + + geom_point(color = "steelblue") + + geom_smooth(method = "lm", se = FALSE, color = "navy") + + geom_text( + data = labels, + aes(label = {{ id }}), + vjust = -0.6, check_overlap = TRUE, size = 4 + ) + + labs(title = title, x = "Female", y = "Male") + + scale_y_continuous(expand = expansion(mult = c(0.05, 0.12))) + + see::theme_modern(base_size = 16) +} +``` + +## Visualize partner similarity + +```{r} +#| output-location: slide +#| dev: svglite +#| fig-width: 12 +#| fig-height: 5.5 +#| out-width: 100% +#| fig-cap: "Labels: four largest Mahalanobis distances in each plot." + +n_mahalanobis <- 4 + +see::plots( + plot_partner_similarity( + apim_distinguishable_wide_data, + efficacy_female, efficacy_male, couple_id, "Efficacy", + n_mahalanobis = n_mahalanobis + ), + plot_partner_similarity( + apim_distinguishable_wide_data, + total_mvpa_female, total_mvpa_male, couple_id, "Daily MVPA", + n_mahalanobis = n_mahalanobis + ) +) +``` + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. [**Estimate the models**]{.text-highlight} +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## Distinguishable APIM + +```{r} +#| label: applied-conceptual-distinguishable-apim +#| echo: false +#| dev: svg +#| fig-width: 9 +#| fig-height: 4.8 +#| out-width: 100% +#| fig-align: center +#| fig-alt: "Conceptual distinguishable APIM with role-specific actor and partner paths and correlated outcome residuals." + +draw_apim_diagram("distinguishable", predictors_centered = TRUE, + labels = c(predictor = "Efficacy", outcome = "MVPA")) +``` + +:::{.notes} + +This is the same conceptual model introduced in Part I. + +[Sources] + +- @kenny2006dyadic + +::: + +## The APIM starts with two member-specific equations + +For each dyad $i$, each member with role +$r \in \{\mathrm{M},\mathrm{F}\}$ has their own predictor +$X^{(\mathrm{A})}_{ri}$ and their partner's predictor +$X^{(\mathrm{P})}_{ri}$: + +$$ + \begin{gathered} + Y_{\mathrm{M},i} + = b_{0,\mathrm{M}} + + \color{#1769AA}{a_{\mathrm{M}} \times X^{(\mathrm{A})}_{\mathrm{M},i}} + + \color{#7B3FA1}{p_{\mathrm{M}} \times X^{(\mathrm{P})}_{\mathrm{M},i}} + + \epsilon_{\mathrm{M},i} + \\ + Y_{\mathrm{F},i} + = b_{0,\mathrm{F}} + + \color{#1769AA}{a_{\mathrm{F}} \times X^{(\mathrm{A})}_{\mathrm{F},i}} + + \color{#7B3FA1}{p_{\mathrm{F}} \times X^{(\mathrm{P})}_{\mathrm{F},i}} + + \epsilon_{\mathrm{F},i} + \end{gathered} +$$ + +[**- Actor effects**]{style="color: #1769AA"} [**- Partner effects**]{style="color: #7B3FA1"} + +In long format, each equation applies to one member row of the dyad. + +How can we combine these two equations into one model? + + +## Role indicators combine the equations + +The indicators $D_{\mathrm{M},ri}$ and $D_{\mathrm{F},ri}$ identify the male +or female row: + +$$ +\begin{aligned} +Y_{ri} ={}& +\underbrace{ + b_{0,\mathrm{M}} \times D_{\mathrm{M},ri} + + b_{0,\mathrm{F}} \times D_{\mathrm{F},ri} +}_{\text{role-specific intercepts}} +\\[0.35em] +&+ +\color{#1769AA}{ +\underbrace{ + a_{\mathrm{M}} \times D_{\mathrm{M},ri} \times X^{(\mathrm{A})}_{ri} + + a_{\mathrm{F}} \times D_{\mathrm{F},ri} \times X^{(\mathrm{A})}_{ri} +}_{\text{role-specific actor effects}} +} +\\[0.35em] +&+ +\color{#7B3FA1}{ +\underbrace{ + p_{\mathrm{M}} \times D_{\mathrm{M},ri} \times X^{(\mathrm{P})}_{ri} + + p_{\mathrm{F}} \times D_{\mathrm{F},ri} \times X^{(\mathrm{P})}_{ri} +}_{\text{role-specific partner effects}} +} ++ \epsilon_{ri}. +\end{aligned} +$$ + +:::{.text-smaller} + +For a male row: $D_\mathrm{M}=1,\ D_\mathrm{F}=0$. For a female row: the reverse. + +::: + +:::{.notes} + +The role indicators correspond to `.is_male` and `.is_female`. The actor and +partner values correspond to `.efficacy_gmc_actor` and `.efficacy_gmc_partner`. +The role index is written first, followed by the dyad index, as in +$Y_{\mathrm{male},i}$ and $Y_{\mathrm{female},i}$. + +[Sources] + +- @kenny2006dyadic + +::: + +## Residuals remain correlated within dyads + +The two member rows from the same dyad retain a joint residual structure: + +$$ +\operatorname{Cov} +\begin{pmatrix} +\epsilon_{\mathrm{F}i} \\ +\epsilon_{\mathrm{M}i} +\end{pmatrix} += \boldsymbol{\Sigma}_{\epsilon} += +\begin{bmatrix} +\sigma_{\epsilon_\mathrm{F}}^{2} +& +\rho_{\epsilon_\mathrm{F}\epsilon_\mathrm{M}} +\sigma_{\epsilon_\mathrm{F}}\sigma_{\epsilon_\mathrm{M}} \\ +\rho_{\epsilon_\mathrm{F}\epsilon_\mathrm{M}} +\sigma_{\epsilon_\mathrm{F}}\sigma_{\epsilon_\mathrm{M}} +& +\sigma_{\epsilon_\mathrm{M}}^{2} +\end{bmatrix} +$$ + + +## Fitting the distinguishable APIM in glmmTMB + +```{r} +#| code-line-numbers: "1-23|4|5-6|8-10|12-14|16-18|19-20|23|1-23" +#| output-location: slide + +library(glmmTMB) + +apim_distinguishable_model <- glmmTMB( + total_mvpa ~ + # Role-specific intercepts + 0 + .is_female + .is_male + + + # Role-specific actor effects + .is_female:.efficacy_gmc_actor + + .is_male:.efficacy_gmc_actor + + + # Role-specific partner effects + .is_female:.efficacy_gmc_partner + + .is_male:.efficacy_gmc_partner + + + # Within-dyad residual covariance + (0 + .is_female + .is_male | couple_id), + dispformula = ~ 0, + family = gaussian(), + data = apim_distinguishable_data +) + +summary(apim_distinguishable_model) + + +``` + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. [**Verify model adequacy, distinguishability, and robustness**]{.text-highlight} +6. **Visualize, interpret, and report results** + +:::{.notes} + +Before interpreting results, verify estimation, model adequacy, +distinguishability, and robustness. + +::: + +## Verify model adequacy, distinguishability, and robustness + +1. Did estimation succeed? +2. Does the model reproduce the important data patterns? +3. Is distinguishability supported? +4. Are conclusions robust or driven by few dyads or consequential + modeling choices? (sensitivity analyses) + +## Did estimation succeed / converge? + +The model converged without warnings... a good first sign! + +:::{.fragment} +**Other things to look out for in the model output:** + +- Estimated variances near $0$ or correlations near $\pm 1$ $\rightarrow$ possible boundary fit +- `NaN` or infinite estimates, standard errors, or model fit indices + +::: + +## Residual diagnostics / reproduction of data patterns + +Residual diagnostics are not as straightforward anymore + +- Linear models: straightforward checks +- Mixed models: residuals arise at multiple levels +- Generalized models: expectations depend on the family and link +- Dyadic models: partners' residuals are correlated + +**Solution:** Compare the data with simulations from the fitted model. + + +## DHARMa: one diagnostic scale across models + +The `DHARMa` package [@hartigDHARMaResidualDiagnostics2026]: + +- Simulates outcomes from the fitted model +- Checks whether the observed residuals behave as expected under simulations from the fitted model. +- Adequate fit $\rightarrow$ approximately uniform, pattern-free residuals + +One function works across many model families! + +## Simulate the full dyadic residual structure + +```{r} +#| label: simulate-dharma-distinguishable +#| cache: true +#| cache.extra: !expr digest::digest(list(stats::logLik(apim_distinguishable_model), stats::model.frame(apim_distinguishable_model))) + +library(DHARMa) + +apim_distinguishable_dharma_residuals <- DHARMa::simulateResiduals( + fittedModel = apim_distinguishable_model, + n = 10000, + + # Since our model uses dispformula = ~ 0, we cannot use DHARMa's default + # conditional simulations. With unconditional, the random-effects block representing + # our residuals is re-simulated. + simulateREs = "unconditional", + + # Male and female residuals are correlated. DHARMa estimates this correlation + # from the simulations and rotates the residuals to "remove" it. + rotation = 'estimated', + seed = 123 +) +``` + +## Inspect DHARMa residuals {.smaller} + +:::: {.columns} + +::: {.column width="75%"} + +```{r} +#| fig-format: svg +#| echo: false + +plot(apim_distinguishable_dharma_residuals) + +``` + +::: + +::: {.column width="25%"} + +**In this model:** + +- Uniformity and dispersion are plausible +- No simulation outliers +- A fitted-value pattern remains + +**Next:** inspect roles without rotation. + +::: + +:::: + +More targeted checks and guidance on interpretation of the plots: +[DHARMa vignette](https://stat.ethz.ch/CRAN/web/packages/DHARMa/vignettes/DHARMa.html). + +## Inspect DHARMa residuals by role + +```{r} + +apim_distinguishable_female_dharma_residuals <- DHARMa::recalculateResiduals( + apim_distinguishable_dharma_residuals, + + # Recalculate from the same simulations for one role. + # One observation per couple: no rotation needed. + sel = ~ .is_female == 1, + rotation = NULL, + seed = 123 +) + +apim_distinguishable_male_dharma_residuals <- DHARMa::recalculateResiduals( + apim_distinguishable_dharma_residuals, + sel = ~ .is_male == 1, + rotation = NULL, + seed = 123 +) +``` + +## The fitted-value pattern appears among women {.smaller} + + +:::: {.columns} + +::: {.column width="75%"} + +```{r} +#| echo: false +#| fig-format: svg +#| fig-width: 10 +#| fig-height: 4.6 +#| out-width: 100% + +old_par <- par(mfrow = c(1, 2), mar = c(4, 4, 4.5, 1)) +DHARMa::plotResiduals( + apim_distinguishable_female_dharma_residuals, + main = "Women" +) +DHARMa::plotResiduals( + apim_distinguishable_male_dharma_residuals, + main = "Men" +) +par(old_par) +``` + + +::: + +::: {.column width="25%"} + +**In this model:** + +- Pattern detected among women +- No comparable pattern among men + +**Next:** try a defensible outcome scale. + + +::: + +:::: + +More targeted checks and guidance on interpretation of the plots: +[DHARMa vignette](https://stat.ethz.ch/CRAN/web/packages/DHARMa/vignettes/DHARMa.html). + +## Square-root MVPA reduces the fitted-value pattern {.smaller} + +```{r} +#| label: simulate-dharma-distinguishable-sqrt +#| include: false +#| cache: true +#| cache.extra: !expr digest::digest(list(stats::logLik(apim_distinguishable_model), stats::model.frame(apim_distinguishable_model))) + +apim_distinguishable_sqrt_data <- apim_distinguishable_data |> + dplyr::mutate(sqrt_total_mvpa = sqrt(total_mvpa)) + +apim_distinguishable_sqrt_model <- update( + apim_distinguishable_model, + sqrt_total_mvpa ~ ., + data = apim_distinguishable_sqrt_data +) + +apim_distinguishable_sqrt_dharma_residuals <- DHARMa::simulateResiduals( + fittedModel = apim_distinguishable_sqrt_model, + n = 10000, + simulateREs = "unconditional", + rotation = 'estimated', + seed = 123 +) +``` + +:::: {.columns} + +::: {.column width="70%"} + +```{r} +#| echo: false +#| fig-format: svg + +plot(apim_distinguishable_sqrt_dharma_residuals) + +``` +::: + +::: {.column width="30%"} + +**Compared with raw MVPA:** + +- Uniformity and dispersion are plausible +- No simulation outliers +- No pooled fitted-value pattern + +**Substantive result unchanged:** actor effects remain positive and supported; +partner effects remain unsupported. + +::: + +:::: + +:::{.subtle} + +**In this example:** + +- **Sensitivity analysis:** square-root MVPA; conclusions unchanged +- **Primary analysis:** report the prespecified raw-MVPA model because the + deviation was modest and minutes are directly interpretable +- **General rule:** larger or consequential diagnostic problems: revise main + model + +::: + +## Transform—or change the outcome family? + +- **Transformation may help** for a nonnegative, right-skewed outcome + - Try `sqrt()` or `log1p()` (handles zeros) + - Refit and rerun DHARMa; the histogram alone is not sufficient + +- **A non-Gaussian family may be preferable** + - Particularly for counts, proportions, bounded, or zero-heavy outcomes + - Family and link choices require outcome-specific care + +- **Workshop scope:** generalized models are not covered here + +## Test distinguishability + +- Fit model with exchangeability constraints + - Partial constraints can be very informative! + +- Compare models + +- Pool only if theoretically defensible, aligned with RQ and theory, and +compatible with the data + - Depending on goals you can also report the distinguishable model and + report results from this analysis + +However, non-significant comparisons are not proof that roles are identical. + +[@gistelinckIndistinguishabilityTests2018]{.subtle} + +## Estimate and compare: + +```{r include=FALSE} + +apim_exchangeable_comparison_model <- glmmTMB( + total_mvpa ~ + # Pooled intercept + 1 + + + # Pooled actor effect + .efficacy_gmc_actor + + + # Pooled partner effect + .efficacy_gmc_partner + + + # Within-dyad residual covariance + (1 | couple_id) + + (0 + .member_contrast_arbitrary | couple_id), + dispformula = ~ 0, + family = gaussian(), + data = apim_distinguishable_data +) + +summary(apim_exchangeable_comparison_model) + +dyadMLM::recover_exchangeable_covariance(apim_exchangeable_comparison_model) + +``` + +```{r} + +dyadMLM::compare_nested_models( + apim_distinguishable_model, apim_exchangeable_comparison_model +) + +``` + +## Test robustness - are conclusions driven by few dyads? + +```{r} +plot_actor_association <- function(data, model, role, title, + n_mahalanobis = 3) { + xy <- cbind(data$.efficacy_gmc_actor, data$total_mvpa) + labels <- data |> + dplyr::mutate(.distance = mahalanobis(xy, colMeans(xy), cov(xy))) |> + dplyr::slice_max(.distance, n = n_mahalanobis) + coefficients <- glmmTMB::fixef(model)$cond + + ggplot(data, aes(.efficacy_gmc_actor, total_mvpa)) + + geom_point(color = "steelblue") + + geom_abline(intercept = coefficients[role], + slope = coefficients[paste0(role, ":.efficacy_gmc_actor")], + color = "navy", linewidth = 16 / 11) + + geom_text( + data = labels, aes(label = couple_id), + vjust = -0.6, check_overlap = TRUE, size = 4 + ) + + labs( + title = title, + x = "Actor efficacy (grand-mean centered)", + y = "Daily MVPA (minutes)" + ) + + scale_y_continuous(expand = expansion(mult = c(0.05, 0.12))) + + see::theme_modern(base_size = 16) + + theme(plot.title.position = "panel", + plot.title = element_text(hjust = 0.5)) +} +``` + +## Test robustness - are conclusions driven by few dyads? + +```{r} +#| output-location: slide +#| dev: svglite +#| fig-width: 12 +#| fig-height: 5.2 +#| out-width: 100% +#| fig-cap: "Labels: four largest Mahalanobis distances in each plot." + +n_mahalanobis <- 4 + +see::plots( + plot_actor_association( + dplyr::filter(apim_distinguishable_data, gender == "female"), + apim_distinguishable_model, ".is_female", "Women", + n_mahalanobis = n_mahalanobis + ), + plot_actor_association( + dplyr::filter(apim_distinguishable_data, gender == "male"), + apim_distinguishable_model, ".is_male", "Men", + n_mahalanobis = n_mahalanobis + ) +) + + patchwork::plot_layout( + axes = "collect", + axis_titles = "collect" + ) +``` + + +## Omitting Couple 28 changes the associations + + +```{r} + +apim_without_couple_28 <- update( + apim_distinguishable_model, + data = filter(apim_distinguishable_data, couple_id != 28) +) + +actor_sensitivity <- parameters::compare_parameters( + `Full data` = apim_distinguishable_model, + `Without Couple 28` = apim_without_couple_28, + keep = "\\.efficacy_gmc_actor" +) + +``` + + + +```{r} +#| echo: false + +actor_sensitivity_table <- format( + actor_sensitivity, + select = "{estimate}{stars}", + format = "text" +) |> + filter( + !is.na(Parameter), + Parameter != "Observations" + ) |> + mutate( + Parameter = c("Women", "Men") + ) |> + rename( + `Actor slope` = Parameter + ) + +slide_table( + actor_sensitivity_table, + align = c("l", "r", "r") +) +``` + +:::{.subtle} +\* $p < .05$; \*\* $p < .01$. Couple 28 was flagged in both visual screens. +Its omission weakens both slopes; only the men's result crosses $p=.05$. +::: + +:::{.notes} + +Couple 28 had the largest Mahalanobis distance in both role-specific visual +screens. Mahalanobis distance identifies an unusual value combination, not +formal coefficient influence. This targeted refit asks the narrower question: +do the actor-effect conclusions materially change without that dyad? + +Both actor slopes remain positive. The women's slope decreases from 11.87 to +8.44 and remains significant. The men's slope decreases from 7.97 to 5.23, +with its two-sided Wald $p$-value moving from .027 to .078. + +The full-data analysis remains primary. Do not remove Couple 28 merely because +its omission changes a significance label. If several cases were +substantively or procedurally flagged before modeling, repeat the same +sensitivity check for those cases. + +::: + +## Other sensitivity analyses you could do + +Fit a small set of (prespecified) models to test: + +- coding decisions +- different plausible outcome families or transformations +- missing-data handling +- covariates with a substantive confounding or precision rationale + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. [**Visualize, interpret, and report results**]{.text-highlight} + +## Reporting results and answering the research question + +```{r} +library(parameters) + +parameters::model_parameters(apim_distinguishable_model, effects = 'fixed') |> + insight::print_md(footer = "") + +``` + +::: {.fragment} +In this sample, higher self-efficacy was associated with more of one’s own MVPA +for both women and men, but not clearly with the partner’s MVPA. +::: + +## Reporting results and answering the research question + +Random effects in our model represent the residual structure + +```{r} + +parameters::model_parameters(apim_distinguishable_model, effects = 'random') |> + insight::print_md(footer = "") + +``` + +## Visualize results + +```{r} +#| fig-format: svg +#| out-width: 70% + + +parameters::model_parameters(apim_distinguishable_model, effects = "fixed") |> + plot() + +``` + +## What should be reported? + +- **Analysis sample:** dyads and observations, exclusions, aggregation, and missing-data handling +- **Model specification:** outcome family and link, fixed effects, dyadic covariance structure, and equality constraints +- **Estimation and model decision:** estimator, software and version, convergence, boundary estimates, distinguishability comparison, and retained model +- **Results:** focal estimates with 95% confidence intervals in substantive units and the fitted variance-covariance parameters +- **Checks and interpretation:** residual diagnostics, influential dyads, prespecified sensitivity analyses, material changes, and causal limits + + +# Short break! + +:::{.notes} + +15:30 - 15:45 + +::: + +# Exchangeable dyads +The same model but constrained + +## Workflow + +1. [**Define dyads, distinguishability, and research questions**]{.text-highlight} +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## Define dyads, distinguishability, and research questions + +> Same data and RQ, now with exchangeability constraints for illustration. + +:::{.notes} + +Since we now know that a distinguishable model is not better than an exchangeable one, +we can use the same RQ and data to demonstrate the exchangeable workflow. + +::: + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. [**Prepare the data and validate the dyadic structure**]{.text-highlight} +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + + +## Create the required format and validate the data + +You can use `dyadMLM::prepare_dyad_data()` to prepare and validate the data. + +For exchangeable dyads, we can just omit the `role` argument. + +```{r} +#| output-location: slide + +apim_exchangeable_data <- dyadMLM::prepare_dyad_data( + data = raw_dyad_data, + dyad = couple_id, + member = person_id, + predictors = efficacy, + model_types = 'apim', + add_apim_gmc_predictors = TRUE, + seed = 123 +) + +print(apim_exchangeable_data) + +``` + +:::{.subtle} +If we want to estimate both distinguishable and exchangeable versions, +we would pass `role` and set `include_arbitrary_member_contrast = TRUE`. +::: + +## Create the required format and validate the data + +Looking at the relevant columns: + +```{r} +head(apim_exchangeable_data) |> + dplyr::select( + couple_id, person_id, .member_contrast_arbitrary, .efficacy_gmc, + .efficacy_gmc_actor, .efficacy_gmc_partner, total_mvpa + ) |> + slide_table() +``` + + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. [**Describe and visualize measures and observed relationships**]{.text-highlight} +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## Describe focal variables (pooled) + +No wide-view of the data is needed for exchangeable dyads. +We can describe the data directly to obtain pooled estimates: + +```{r} +apim_exchangeable_data |> + dplyr::select(efficacy, total_mvpa) |> + report::report_table() |> + slide_table() +``` + +## Visualize focal variables + +```{r} + +plot_pooled_histogram <- function(data, var) { + var_label <- rlang::as_label(rlang::enquo(var)) + + ggplot( + data, + aes(x = {{ var }}, y = after_stat(density)) + ) + + geom_histogram( + bins = 15, boundary = 0, + fill = "steelblue", color = "white", alpha = 0.75 + ) + + geom_density( + bounds = c(0, Inf), color = "navy", linewidth = 1.1 + ) + + see::theme_modern(base_size = 16) +} + +``` + +## Visualize focal variables + +```{r} +#| fig-format: svg +#| out-width: 100% + +see::plots( + plot_pooled_histogram(apim_exchangeable_data, efficacy), + plot_pooled_histogram(apim_exchangeable_data, total_mvpa) +) +``` + +## Observed correlations + +For exchangeable dyads, ICCs summarize partner similarity: + +```{r} +library(wbCorr) + +apim_exchangeable_correlations <- wbCorr( + apim_exchangeable_data[,c('efficacy','total_mvpa')], + cluster = apim_exchangeable_data$couple_id +) + +summary(apim_exchangeable_correlations, 'wb') +``` + +**Diagonal ICCs:** expected correlation between partners on each variable + +[**Off-diagonals:** top right = within-couple correlation; bottom left = between-couple correlation]{.subtle} + +## Visualize partner similarity + +```{r} +#| output-location: slide +#| dev: svglite +#| fig-width: 12 +#| fig-height: 5.5 +#| out-width: 100% +#| fig-cap: "Each couple is shown twice—once in each orientation; labels mark the four largest dyad-level Mahalanobis distances." + +partner_similarity_data <- apim_exchangeable_data |> + dplyr::group_by(couple_id) |> + dplyr::mutate( + efficacy_partner = rev(efficacy), + total_mvpa_partner = rev(total_mvpa) + ) |> + dplyr::ungroup() + +see::plots( + plot_partner_similarity( + partner_similarity_data, + efficacy, efficacy_partner, couple_id, "Efficacy", + n_mahalanobis = 4 + ) + + labs(x = "Focal member", y = "Partner"), + plot_partner_similarity( + partner_similarity_data, + total_mvpa, total_mvpa_partner, couple_id, "Daily MVPA", + n_mahalanobis = 4 + ) + + labs(x = "Focal member", y = "Partner") +) +``` + + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. [**Estimate the models**]{.text-highlight} +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## Exchangeable APIM + +```{r} +#| label: applied-conceptual-exchangeable-apim +#| echo: false +#| dev: svg +#| fig-width: 9 +#| fig-height: 4.8 +#| out-width: 100% +#| fig-align: center +#| fig-alt: "Conceptual exchangeable APIM with pooled actor and partner paths and correlated outcome residuals." + +draw_apim_diagram("exchangeable", predictors_centered = TRUE, + labels = c(predictor = "Efficacy", outcome = "MVPA")) +``` + +## In MLM we constrain / pool by omitting terms + +One single equation: + +For each dyad $i$, each member $j$ has their own predictor +$X^{(\mathrm{A})}_{j,i}$ and their partner's predictor $X^{(\mathrm{P})}_{j,i}$: + +$$ + Y_{j,i} + = b_{0} + + \color{#1769AA}{a \times X^{(\mathrm{A})}_{j,i}} + + \color{#7B3FA1}{p \times X^{(\mathrm{P})}_{j,i}} + + \epsilon_{j,i} +$$ + +[**- Actor effects**]{style="color: #1769AA"} [**- Partner effects**]{style="color: #7B3FA1"} + +In long format, each equation applies to one member row of the dyad. + + +## The tricky part: residuals need to remain correlated within dyads + +- The two member rows from the same dyad retain a joint residual structure + +- Both members now have the same residual variance (pooled) + +- Position 1 and 2 within the dyad are arbitrary + + +$$ +\operatorname{Cov} +\begin{pmatrix} +\epsilon_{1i} \\ +\epsilon_{2i} +\end{pmatrix} += \boldsymbol{\Sigma}_{\epsilon} += +\begin{bmatrix} +\sigma_{\epsilon}^{2} +& +\rho_{\epsilon_1\epsilon_2}\sigma_{\epsilon}^{2} \\ +\rho_{\epsilon_1\epsilon_2}\sigma_{\epsilon}^{2} +& +\sigma_{\epsilon}^{2} +\end{bmatrix} +$$ + +## Fitting the exchangeable APIM in glmmTMB + +```{r results='hide'} +#| code-line-numbers: "1-25|2|3-4|6-7|9-10|12-20|14-15|17-18|20|1-23" +apim_exchangeable_model <- glmmTMB( + total_mvpa ~ + # Pooled intercept + 1 + + + # Pooled actor effect + .efficacy_gmc_actor + + + # Pooled partner effect + .efficacy_gmc_partner + + + #------ Within-dyad residual covariance (Sum/Deviation) ------ + + # Residuals of partners might be similar (positively correlated) + (1 | couple_id) + + + # Residuals of partners might move opposite (negatively correlated) + (0 + .member_contrast_arbitrary | couple_id), + + dispformula = ~ 0, + family = gaussian(), + data = apim_exchangeable_data +) + +summary(apim_exchangeable_model) +``` + + +:::{.notes} + +Explain why we do this on next page + +::: + +## The mean-deviation parameterization + +- The DIM is equivalent to the APIM + +- The DIM represents member residuals using two uncorrelated components: + + - Mean block `(1 | couple_id)`: + $r_{\mathrm{M}i}=(\epsilon_{1i}+\epsilon_{2i})/2$; both members move together + + - Deviation block `(0 + .member_contrast_arbitrary | couple_id)`: + $r_{\mathrm{D}i}=(\epsilon_{1i}-\epsilon_{2i})/2$; members move in opposite + directions + +Using this parametrization allows us to represent random effects and later +in ILD even random slopes with the correct constraints. + +We can later backtransform to the familiar person-level structure. + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. [**Verify model adequacy, distinguishability, and robustness**]{.text-highlight} +6. **Visualize, interpret, and report results** + +## Verify model adequacy, distinguishability, and robustness + +Same as before: + +1. Did estimation succeed? +2. Does the model reproduce the important data patterns? +3. Does a distinguishable model fit clearly better? +4. Are conclusions robust or driven by few dyads or consequential + modeling choices? (sensitivity analyses) + +:::{.notes} + +Just brief recap, no more slides + +- Regarding distinguishability: depends on the data! could test various +distinguishing variables. + +::: + + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. [**Visualize, interpret, and report results**]{.text-highlight} + + +## Reporting results and answering the research questions + +```{r} +parameters::model_parameters(apim_exchangeable_model, effects = 'fixed') |> + insight::print_md(footer = "") +``` + + +::: {.fragment} +In the parsimonious exchangeable model, higher self-efficacy was associated +with more of one’s own MVPA, but not clearly with the partner’s MVPA. +::: + + +## Reporting results and answering the research questions + +```{r} +parameters::model_parameters(apim_exchangeable_model, effects = 'random') |> + insight::print_md(footer = "") +``` + +:::{.fragment} +Often it is preferable to rotate the covariance back to the familiar member-level covariance matrix: + +- Member residual variance: + $\operatorname{Var}(\epsilon_{1i})=\operatorname{Var}(\epsilon_{2i}) + =\operatorname{Var}(r_{\mathrm{M}i})+\operatorname{Var}(r_{\mathrm{D}i})$ + +- Partner residual covariance: + $\operatorname{Cov}(\epsilon_{1i},\epsilon_{2i}) + =\operatorname{Var}(r_{\mathrm{M}i})-\operatorname{Var}(r_{\mathrm{D}i})$ + +::: + +## Reporting results and answering the research questions + +No need to do so by hand. Rotating back with `dyadMLM`: + +```{r} + +dyadMLM::recover_exchangeable_covariance(apim_exchangeable_model) + +``` + + +## Visualize results + + +```{r} +#| fig-format: svg +#| out-width: 70% + +parameters::model_parameters(apim_exchangeable_model, effects = 'fixed') |> + plot(show_intercept = TRUE) + +``` + +# Optional: DIM and DSM + +::: {.workshop-next} +Worked examples are available in the package vignettes of `dyadMLM`. + +[Open the DIM vignette →](https://pascal-kueng.github.io/dyadMLM/articles/dim.html){.workshop-next-link} + +[Open the DSM vignette →](https://pascal-kueng.github.io/dyadMLM/articles/dsm.html){.workshop-next-link} +::: + + + + + + +# Intensive longitudinal APIM + +## Intensive longitudinal APIM - Workflow + +**We can follow the same workflow. Additional possible ILD considerations:** + +- Check compliance / missingness +- Inspect and visualize paired trajectories and patterns +- Separate within- and between-person variation + - Inspect ICCs and multilevel reliability where applicable + - Model dyads on multiple levels +- Check and account for residual temporal dependence + +::: {.subtle} +Synthesized from @bolgerIntensiveLongitudinalMethods2013, +@revolPreprocessingExperienceSampling2024, @mcneishPrimerTwoLevel2020, and +@delrosarioPracticalGuideSpecifying2025. + +::: + +## Workflow + +1. [**Define dyads, distinguishability, and research questions**]{.text-highlight} +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## The Dataset + +**Same as before:** + +- 36 physically inactive romantic couples +- Both partners intended to become more physically active +- Smartphone-based planning interventions and JITAIs +- Daily diaries over 55 days + +**Not aggregated anymore** + +## ILD Research Question {.rq-slide} + +::: {.rq-center} +::: {.rq-card} +[RQ:]{.rq-label} [How are **previous-day deviations** and stable between-person +differences in perceived behavioral control over next-day physical activity +associated with one's own and one's partner's **current-day MVPA**?]{.rq-text} +::: +::: + +:::{.notes} + +Partner effects may reflect shared schedules, constraints, plans, or +support—not necessarily causal interpersonal influence. + +::: + +## Measurement - predictor + +### Perceived behavioral control (PBC) over next-day physical activity + +> **Rough English translation of the original German item**
+> “Being physically active tomorrow would/will be for me …” +> +> [Adapted from @ajzenTheoryPlannedBehavior1991]{.subtle} + +0 = *impossible—crucial prerequisites are not met*
+3 = *possible with some effort—several prerequisites are not met*
+6 = *easily possible—all prerequisites are met* + +- Lagged predictor: perceived behavioral control on day $t-1$, MVPA on day $t$ + + + +## Measurement - outcome + +### Device-based MVPA + +> **Accelerometer-derived measure**
+> Daily minutes of moderate-to-vigorous physical activity + +- Days with less than 10 hours of awake wear time $\rightarrow$ `NA` +- Analyze $\log(\text{MVPA})$ to reduce right skew + +:::{.subtle} +Exponentiated coefficients describe multiplicative differences in MVPA. +::: + + + +## Workflow + +1. **Define dyads, distinguishability, and research questions** +2. [**Prepare the data and validate the dyadic structure**]{.text-highlight} +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## Load the daily measures + +We set MVPA to `NA` on days with less than 10 hours of weartime, center time at +the middle of the study in full-study units, and select the needed variables. + +```{r} +#| output-location: slide +raw_ild_dyad_data <- readRDS("dyadic-data.rds") |> + dplyr::mutate( + device_based_mvpa = dplyr::if_else( + awake_wear_minutes >= 600, + device_based_mvpa, + NA + ), + log_device_based_mvpa = log(device_based_mvpa), + diaryday_c = (diaryday - 27) / 54 + )|> + dplyr::select( + couple_id, person_id, diaryday, diaryday_c, gender, + pbc = perceived_behavioral_control, + device_based_mvpa, log_device_based_mvpa, awake_wear_minutes + ) |> + dplyr::arrange(couple_id, diaryday, person_id) + +slide_table(head(raw_ild_dyad_data)) +``` + + + +## Create the required format and validate the data + +For ILD we **decompose the predictor(s)**: + +- Between-person component: Person mean centered on the mean of person means + (stable) + - $\bar X_{ri} - \bar X$ +- Within-person component: Daily deviations from the person mean + - $X_{ri,t} - \bar X_{ri}$ + +In this example we then lag the within-person component ($X_{ri,t-1}$) + +## Create the required format and validate the data [Manual code →](#manual-ild-apim-preparation){.results-forward-link} {#prepared-ild-apim-data} + +The `dyadMLM` package can handle centering alongside the construction +and validation of the dyadic dataset: + +```{r} +#| output-location: slide + +ild_apim_data <- dyadMLM::prepare_dyad_data( + data = raw_ild_dyad_data, + dyad = couple_id, + member = person_id, + role = gender, + time = diaryday, + predictors = pbc, + lag1_predictors = pbc, + model_types = "apim", + temporal_decomposition = "2l", + include_arbitrary_member_contrast = TRUE, + seed = 123 +) + +ild_apim_data <- ild_apim_data |> + dplyr::mutate( + diaryday_f = factor(diaryday, levels = 0:54) + ) + +print(ild_apim_data) +``` + +## Workflow +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. [**Describe and visualize measures and observed relationships**]{.text-highlight} +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## Report measures + +Among other things you may check and report: + +- Missingness and general summary statistics +- ICCs +- Within- and between- person correlations (e.g., with `wbCorr`) +- Visualize outcome trajectories over time + +## Plot paired raw MVPA trajectories + +```{r} +#| label: paired-raw-mvpa-trajectories +#| output-location: slide +#| fig-format: svg +#| fig-width: 10 +#| fig-height: 5.2 +#| out-width: 100% +#| fig-align: center + +raw_ild_dyad_data |> + dplyr::filter(couple_id %in% c(2, 7, 17, 26)) |> + ggplot(aes(diaryday, device_based_mvpa, color = gender, + group = person_id)) + + geom_line(linewidth = 0.65, na.rm = TRUE) + + geom_point(size = 1.1, na.rm = TRUE) + + facet_wrap(~ couple_id, ncol = 2) + + scale_color_manual(values = c(female = "#004D40", male = "#00A6B2")) + + scale_y_continuous(breaks = seq(0, 300, by = 100)) + + labs(x = "Diary day", y = "MVPA (minutes)", color = NULL) + + see::theme_modern(base_size = 16) + + theme(legend.position = "top") +``` + +## Workflow +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. [**Estimate the models**]{.text-highlight} +5. **Verify model adequacy, distinguishability, and robustness** +6. **Visualize, interpret, and report results** + +## Fitting the ILD APIM: Two member-specific equations + +For dyad $i$ at occasion $t$, superscripts $\mathrm{W}$ and $\mathrm{B}$ +denote within-person and between-person components. + +$$ +\begin{aligned} +Y_{\mathrm{M},i,t} ={}& +b_{0,\mathrm{M}} ++ \color{#1769AA}{ + a^{\mathrm{W}}_{\mathrm{M}}X^{(\mathrm{A,W})}_{\mathrm{M},i,t-1} + + a^{\mathrm{B}}_{\mathrm{M}}X^{(\mathrm{A,B})}_{\mathrm{M},i} +} ++ \color{#7B3FA1}{ + p^{\mathrm{W}}_{\mathrm{M}}X^{(\mathrm{P,W})}_{\mathrm{M},i,t-1} + + p^{\mathrm{B}}_{\mathrm{M}}X^{(\mathrm{P,B})}_{\mathrm{M},i} +} ++ u_{0,\mathrm{M}i} ++ \epsilon_{\mathrm{M},i,t} +\\[0.6em] +Y_{\mathrm{F},i,t} ={}& +b_{0,\mathrm{F}} ++ \color{#1769AA}{ + a^{\mathrm{W}}_{\mathrm{F}}X^{(\mathrm{A,W})}_{\mathrm{F},i,t-1} + + a^{\mathrm{B}}_{\mathrm{F}}X^{(\mathrm{A,B})}_{\mathrm{F},i} +} ++ \color{#7B3FA1}{ + p^{\mathrm{W}}_{\mathrm{F}}X^{(\mathrm{P,W})}_{\mathrm{F},i,t-1} + + p^{\mathrm{B}}_{\mathrm{F}}X^{(\mathrm{P,B})}_{\mathrm{F},i} +} ++ u_{0,\mathrm{F}i} ++ \epsilon_{\mathrm{F},i,t}. +\end{aligned} +$$ + +[**Actor effects**]{style="color: #1769AA"} · +[**Partner effects**]{style="color: #7B3FA1"} + +:::{.text-smaller .fragment} + +- $u_{0,ri}$: stable member-within-dyad deviation +- $\epsilon_{r,it}$: occasion-specific residual +- **Optional random slope:** add + $u_{\mathrm{A},ri}X^{(\mathrm{A,W})}_{r,i,t-1}$ +- **Same stacking approach:** role indicators select the male or female equation + +::: + +## Repeated measures separate two covariance levels + +:::: {.columns} + +::: {.column width="50%"} + +### Stable across occasions + +`couple_id` + +- Role-specific random intercepts +- Optional role-specific random slopes +- Partner covariance in stable levels or slopes + +::: + +::: {.column width="50%"} + +### At each single occasion + +`couple_id:diaryday` + +- Partner-specific Gaussian residual variance +- Same-occasion residual correlation +- Independent across occasions unless modeled otherwise + +::: + +:::: + +## Fitting the distinguishable ILD APIM with glmmTMB + +```{r} +#| code-line-numbers: "1-38|4-5|7-8|10-17|19-26|28-29|31-36|38" +#| output: false + +ild_apim_distinguishable_model <- glmmTMB::glmmTMB( + log_device_based_mvpa ~ + + # Role-specific fixed intercepts + 0 + .is_female + .is_male + + + # Role-specific fixed time-slope + .is_female:diaryday_c + .is_male:diaryday_c + + + # --------------- WITHIN PERSON APIM --------------- + # Role-specific fixed actor- and partner effects + + .is_female:.pbc_cwp_actor_lag1 + + .is_male:.pbc_cwp_actor_lag1 + + + .is_female:.pbc_cwp_partner_lag1 + + .is_male:.pbc_cwp_partner_lag1 + + + # --------------- BETWEEN PERSON APIM --------------- + # Role-specific fixed actor-and partner effects + + .is_female:.pbc_cbp_actor + + .is_male:.pbc_cbp_actor + + + .is_female:.pbc_cbp_partner + + .is_male:.pbc_cbp_partner + + + # Stable dyad/member random intercepts (correlated) + (0 + .is_female + .is_male | couple_id) + + + # Same-occasion Gaussian residual covariance + (0 + .is_female + .is_male | couple_id:diaryday), + dispformula = ~ 0, + family = gaussian(), + data = ild_apim_data +) + +summary(ild_apim_distinguishable_model) +``` + +## Workflow +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. [**Verify model adequacy, distinguishability, and robustness**]{.text-highlight} +6. **Visualize, interpret, and report results** + +## Testing for residual autocorrelation + +```{r} +#| label: simulate-dharma-ild-no-ar +#| cache: true +#| cache.extra: !expr digest::digest(list(stats::logLik(ild_apim_distinguishable_model), stats::model.frame(ild_apim_distinguishable_model), body(simulate_ild_dharma))) +#| fig-format: svg +#| output-location: slide + + +ild_apim_no_ar_dharma <- simulate_ild_dharma( + model = ild_apim_distinguishable_model, + dyad = ild_apim_data$couple_id, + member = ild_apim_data$person_id, + time = ild_apim_data$diaryday, + n = 1000, + seed = 123 +) + +diagnostic <- test_ild_lag1( + ild_apim_no_ar_dharma, + plot = TRUE +) +``` + +:::{.subtle} +The helper compares the observed consecutive-day correlation with correlations +simulated from the fitted model. +::: + +## Add role-specific residual AR(1) processes + +- Separate AR(1) series for the female and male partner +- Role-specific residual variability and persistence $\rho$ +- Same-day partner covariance retained separately + +```{r eval = FALSE} +ild_apim_distinguishable_ar1_model <- update( + ild_apim_distinguishable_model, + . ~ . + + ar1(0 + .is_female:diaryday_f | couple_id) + + ar1(0 + .is_male:diaryday_f | couple_id) +) +``` + +```{r} +#| label: fit-ild-distinguishable-ar1 +#| include: false + +ild_apim_distinguishable_ar1_model <- update( + ild_apim_distinguishable_model, + . ~ . + + ar1(0 + .is_female:diaryday_f | couple_id) + + ar1(0 + .is_male:diaryday_f | couple_id) +) + +ild_apim_distinguishable_ar1_model <- refit_glmmTMB_with_bfgs_if_needed( + ild_apim_distinguishable_ar1_model +) +``` + +```{r} +#| output-location: slide + +glmmTMB::VarCorr(ild_apim_distinguishable_ar1_model) +``` + +:::{.subtle} +The two AR(1) terms represent independent member-specific persistence. The +dyad-day SDs and correlation describe the remaining same-day variation. +::: + +:::{.notes} + +- The `couple_id` SDs of 0.24 for women and 0.26 for men describe stable + between-couple variation in each member's log-MVPA after accounting for the + fixed effects. A one-SD positive deviation corresponds to about 1.27 and 1.30 + times the geometric-mean MVPA, respectively. +- The couple-level correlation of 0.34 means that partners' stable deviations + tend to align moderately: when one partner is persistently above their + expected level, the other also tends to be above theirs. +- The AR(1) SDs of about 0.23 describe the size of each member's persistent + occasion-level component. The AR correlations of 0.88 and 0.81 describe + one-day persistence within those components, not the correlation of the + complete residual. +- The dyad-day SDs of 0.35 and 0.38 describe the remaining nonpersistent + same-day variation. A one-SD positive deviation corresponds to about 1.42 + and 1.46 times the geometric-mean MVPA. +- The dyad-day correlation of 0.39 means that partners' remaining same-day + deviations tend to move together after the stable and persistent components + have been separated. +- The complete occasion-level residual combines the AR and dyad-day variances: + its SDs are about 0.42 and 0.44. Because the two AR processes are independent + across partners, the complete same-day residual correlation is about 0.28, + not 0.39. + +::: + +## Simulate residuals from the AR(1) model + +```{r include=FALSE} +#| label: simulate-dharma-ild +#| cache: true +#| cache.extra: !expr digest::digest(list(stats::logLik(ild_apim_distinguishable_ar1_model), stats::model.frame(ild_apim_distinguishable_ar1_model), body(simulate_ild_dharma))) + +ild_apim_dharma_residuals <- simulate_ild_dharma( + model = ild_apim_distinguishable_ar1_model, + dyad = ild_apim_data$couple_id, + member = ild_apim_data$person_id, + time = ild_apim_data$diaryday, + n = 10000, + seed = 123 +) +``` + +```{r echo = FALSE} +#| fig-format: svg +#| fig-width: 10 +#| fig-height: 4.4 +#| out-width: 92% +#| fig-align: center + +ild_dharma_graphics_parameters <- graphics::par(no.readonly = TRUE) + +plot( + ild_apim_dharma_residuals +) + +graphics::par(ild_dharma_graphics_parameters) +``` + +:::{.subtle} + +With almost 2,800 observations, DHARMa tests are very sensitive. Visual inspection +becomes more meaningful. + +::: + +## Does the fitted AR(1) reproduce lag-1 dependence? + +```{r} +#| fig-format: svg +#| fig-width: 8 +#| fig-height: 3.3 +#| out-width: 70% +#| fig-align: center + +ild_apim_ar1_lag1_test <- test_ild_lag1( + ild_apim_dharma_residuals, + plot = TRUE +) +``` + +:::{.subtle} +The correlation need not become zero. It should be typical under simulations +from the fitted AR(1) model. +::: + +## Fit the exchangeable model with pooled AR(1) + +```{r} +#| output-location: slide + +ild_apim_exchangeable_ar1_model <- glmmTMB::glmmTMB( + log_device_based_mvpa ~ + 1 + + diaryday_c + + .pbc_cwp_actor_lag1 + + .pbc_cwp_partner_lag1 + + .pbc_cbp_actor + + .pbc_cbp_partner + + + # Couple-level variance-covariance structure + (1 | couple_id) + + (0 + .member_contrast_arbitrary | couple_id) + + + # Occasion-level residual variance-covariance structure + (1 | couple_id:diaryday) + + (0 + .member_contrast_arbitrary | couple_id:diaryday) + + ar1(0 + diaryday_f | couple_id:person_id), + dispformula = ~ 0, + family = gaussian(), + data = ild_apim_data +) + +summary(ild_apim_exchangeable_ar1_model) +``` + +```{r} +#| include: false + +ild_apim_exchangeable_ar1_model <- refit_glmmTMB_with_bfgs_if_needed( + ild_apim_exchangeable_ar1_model +) +``` + +:::{.subtle} +Each member retains a separate series, but residual variability and +persistence $\rho$ are pooled across members. +::: + +## Backtransform to member-level variance-covariance structure + +```{r} +dyadMLM::recover_exchangeable_covariance(ild_apim_exchangeable_ar1_model) +``` + + +## Compare distinguishable and exchangeable models + +This is a global test, **partial constraints can be informative too!** + +```{r} +dyadMLM::compare_nested_models( + ild_apim_distinguishable_ar1_model, + ild_apim_exchangeable_ar1_model +) +``` + + + +## Workflow +1. **Define dyads, distinguishability, and research questions** +2. **Prepare the data and validate the dyadic structure** +3. **Describe and visualize measures and observed relationships** +4. **Estimate the models** +5. **Verify model adequacy, distinguishability, and robustness** +6. [**Visualize, interpret, and report results**]{.text-highlight} + + +## Report the retained distinguishable model + +We exponentiate estimates from the log-transformed outcome to obtain geometric +mean ratios (GMRs; representing multiplicative differences). + +```{r} +#| output-location: slide + +parameters::model_parameters( + ild_apim_distinguishable_ar1_model, + effects = 'fixed', + exponentiate = TRUE + ) |> + insight::print_md(footer = "") + +``` + +## Report the retained distinguishable model + +```{r} +#| fig-format: svg +#| fig-width: 13 +#| output-location: slide +see::plots( + parameters::model_parameters( + ild_apim_distinguishable_ar1_model, + effects = "fixed", + exponentiate = TRUE, + keep = "_cwp_" + ) |> plot(), + parameters::model_parameters( + ild_apim_distinguishable_ar1_model, + effects = "fixed", + exponentiate = TRUE, + keep = "_cbp_" + ) |> plot(), + n_columns = 2, + tags = c("Within person", "Between persons") +) & + ggplot2::labs(x = "GMR") +``` + +## Report the retained distinguishable model + +**Within person:** Men’s MVPA was 3.5% higher when their own previous-day PBC was +one point above usual, and 2.5% higher when their partner’s was. + +**Between persons:** There was no clear evidence of actor or partner +associations. + +:::{.notes} + +Supported associations for men but not women do not by themselves establish +that the effects differ by gender; that requires a direct comparison of the +slopes. + +Within-person estimates compare previous-day PBC with one's own usual level; +between-person estimates compare person means. Percent differences are +back-transformations from the log-MVPA model. + +::: + + + +# General reporting practices for ILD APIM studies + +## Many studies lack complete reporting + +```{r} +#| label: plot-longitudinal-apim-reporting-gaps +#| fig-format: svg +#| echo: false +#| fig-width: 10.5 +#| fig-height: 4.5 +#| out-width: 92% +#| fig-align: center +#| fig-alt: "Bar chart of reporting practices in 73 longitudinal APIM studies: 17.8 percent reported a power analysis, 64.4 percent documented model constraints, and 75.3 percent reported a missing-data strategy." + +reporting_gaps <- tibble( + item = factor( + c("Power analysis", "Model constraints", "Missing-data strategy"), + levels = c("Missing-data strategy", "Model constraints", "Power analysis") + ), + reported = c(17.8, 64.4, 75.3) +) + +ggplot(reporting_gaps, aes(item, reported, fill = item == "Power analysis")) + + geom_col(width = 0.65) + + geom_text( + aes(label = paste0(reported, "%")), + hjust = -0.15, size = 7 + ) + + coord_flip(clip = "off") + + scale_fill_manual(values = c("TRUE" = "#0028a5", "FALSE" = "#9aa7bd")) + + scale_y_continuous( + limits = c(0, 100), + breaks = seq(0, 100, 20), + labels = paste0(seq(0, 100, 20), "%"), + expand = c(0, 0) + ) + + labs( + x = NULL, + y = "Studies reporting the item" + ) + + theme_minimal(base_size = 21) + + theme( + legend.position = "none", + panel.grid.major.y = element_blank(), + panel.grid.minor = element_blank(), + plot.margin = margin(5.5, 20, 5.5, 5.5) + ) +``` + +Systematic review of 73 longitudinal APIM studies published from 2008–2025 +[@mohammadzadehYazdBeyondIndividual2026]. + +:::{.notes} + +- The chart shows reporting rates because they are easier to read as adherence + to good practice. +- The power-analysis bar is descriptive; it does not imply that one generic + analytic solution is suitable for every longitudinal APIM. + +::: + +## Make every dyadic analysis decision visible + +1. **Preregister** actor and partner hypotheses and key analysis decisions. +2. **Explain missing data:** describe missingness and the handling strategy. +3. **Specify the full model:** roles and distinguishability, actor and partner + paths, constraints, and covariance structure. +4. **Report reliability where applicable:** within- and between-level omega for + multilevel item scales, e.g., `multilevelTools::omegaSEM()` + [@wileyMultilevelTools2025; @geldhofReliabilityEstimationMultilevel2014]. + +[@mohammadzadehYazdBeyondIndividual2026]{.subtle} + + +# Exercises in R + +- Go to [https://pascal-kueng.github.io/dyadMLM/workshop/](https://pascal-kueng.github.io/dyadMLM/workshop/) +- Link is also in the Teams channel +- Download and unzip all workshop materials +- Start R from that folder (by opening one of the files) + +Run this in the console to ensure all relevant packages are installed and up to date: + +```{r eval = FALSE} +source("00_setup.R") +``` + + +## References + +::: {#refs} +::: + +# Appendix + +## Create the cross-sectional APIM variables manually [← Data preparation](#prepared-apim-data){.appendix-back-link} {#manual-apim-preparation .smaller} + +- Explicit matching by couple and role +- Missing partner $\rightarrow$ `NA` + +```{r} +#| eval: false + +apim_manual_data <- raw_dyad_data |> + dplyr::mutate( + .is_female = as.numeric(gender == "female"), + .is_male = as.numeric(gender == "male"), + .efficacy_gmc = efficacy - mean(efficacy, na.rm = TRUE), + .efficacy_gmc_actor = .efficacy_gmc + ) + +partner_values <- apim_manual_data |> + dplyr::transmute( + couple_id, + gender = dplyr::recode(gender, female = "male", male = "female"), + .efficacy_gmc_partner = .efficacy_gmc + ) + +apim_manual_data <- apim_manual_data |> + dplyr::left_join( + partner_values, + by = c("couple_id", "gender"), + relationship = "one-to-one" + ) +``` + +## Decompose and lag perceived behavioral control manually [← Data preparation](#prepared-ild-apim-data){.appendix-back-link} {#manual-ild-apim-preparation .smaller} + +```{r} +#| eval: false + +pbc_components <- raw_ild_dyad_data |> + dplyr::arrange(couple_id, person_id, diaryday) |> + dplyr::group_by(couple_id, person_id) |> + dplyr::mutate( + .pbc_person_mean = mean(pbc, na.rm = TRUE), + .pbc_cwp = pbc - .pbc_person_mean, + .pbc_cwp_lag1 = dplyr::if_else( + diaryday == dplyr::lag(diaryday) + 1, + dplyr::lag(.pbc_cwp), + NA_real_ + ) + ) |> + dplyr::ungroup() |> + dplyr::mutate( + .pbc_cbp = .pbc_person_mean - + mean( + .pbc_person_mean[ + !duplicated(paste(couple_id, person_id)) + ], + na.rm = TRUE + ) + ) +``` + +## Match actor and partner components manually [← Data preparation](#prepared-ild-apim-data){.appendix-back-link} {#manual-ild-apim-matching .smaller} + +```{r} +#| eval: false + +partner_components <- pbc_components |> + dplyr::transmute( + couple_id, + diaryday, + gender = dplyr::recode(gender, female = "male", male = "female"), + .pbc_cwp_partner = .pbc_cwp, + .pbc_cwp_partner_lag1 = .pbc_cwp_lag1, + .pbc_cbp_partner = .pbc_cbp + ) + +ild_manual_data <- pbc_components |> + dplyr::rename( + .pbc_cwp_actor = .pbc_cwp, + .pbc_cwp_actor_lag1 = .pbc_cwp_lag1, + .pbc_cbp_actor = .pbc_cbp + ) |> + dplyr::left_join( + partner_components, + by = c("couple_id", "diaryday", "gender"), + relationship = "one-to-one" + ) +``` + +- Explicit day-role matching: independent of row order diff --git a/dev/workshop/dyad-day.html b/dev/workshop/dyad-day.html deleted file mode 100644 index d9dbf60c..00000000 --- a/dev/workshop/dyad-day.html +++ /dev/null @@ -1,5769 +0,0 @@ - - - - - - - - - - - - - - Dyadic Data Analysis with R - - - - - - - - - - - - - - - - - -
-
- -
-

Dyadic Data Analysis with R

-

Part I: Conceptual Foundations

- -
-
-
-Pascal Küng -
-
-
-
-Turu Stadler -
-
-
- -
-
-

Introduction

-
    -
  • Turu & Pascal
  • -
  • Tell us about you and your dyadic data! -
      -
    • Name, affiliation & career stage
    • -
    • Your dyadic data and RQ
    • -
  • -
- -
-
-

Today’s Aims and Program

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
TimeFocus
11:00–12:45Introduction and types of dyadic models
12:45–14:00Lunch break
14:00–15:30Estimating cross-sectional models in R
15:30–15:45Short break
15:45–16:45Intensive longitudinal extensions
16:45–17:00Short break
17:00–18:00Exercises in R
- -
-
-
-

Introduction

-

Relevance and todays’ example dataset

-
-
-

Why dyadic data?

-
-

“Much of what we think, do, and feel is determined not by who we are but by whom we are with.” (Kenny & Cook, 1999, p. 446)

-
-
    -
  • Partners matter: An outcome may depend on both my characteristics and my partner’s characteristics.
  • -
  • Some constructs and processes are dyadic: Shared contexts and interdependence processes can make partners’ outcomes correlated.
  • -
  • The configuration matters: Partners’ similarity, or complementarity (differences) may predict outcomes beyond either individual score.
  • -
-

Kenny & Cook (1999); Iida et al. (2018)

- -
-
-

Introducing today’s dyadic dataset!

-
    -
  • 38 physically inactive opposite-sex romantic couples
  • -
  • Both partners intended to increase their physical activity together
  • -
  • Smartphone-based planning interventions and JITAIs
  • -
  • Daily diaries over 55 days
  • -
-

Küng et al. (2026); Höhener et al. (2026)

- -
-
-

Research Question 1

-
-
-

RQ1: In romantic couples, how is provided health-related social support linked to physical activity?

-
-
- - -
-
-

Measurement - Predictor

-

Emotional support provided

-
-

Rough English translation of the original German item
“How much did you emotionally support your partner today so that they would be physically active with greater enjoyment?”

-

Adapted from Bolger et al. (2000)

-
-

0 = not at all today
5 = very much today

- -
-
-

Measurement - Outcome

-

Moderate to vigorous physical activity (MVPA)

-
-

Rough English translation of the original German item
“How many minutes did you spend engaging in moderate-to-vigorous physical activity today?” Adapted from Amireault & Godin (2015)

-
-
    -
  • Alone: _____ minutes
  • -
  • Together with your partner: _____ minutes
  • -
-

Total MVPA = solo MVPA + joint MVPA.

- -
-
-

Aggregating for cross-sectional examples

-

To show simple dyadic models we aggregate the daily diary data to obtain a “cross-sectional” dataset.

-
-
library(dplyr)
-
-pilot_aggregated <- pilot |>
-  group_by(couple_id, person_id, role) |>
-  summarise(
-    across(where(is.numeric), ~ mean(.x, na.rm = TRUE)),
-    .groups = "drop"
-  )
-
-
-

The variables now represent person-level daily averages across the study:

-
    -
  • provided_emotional_support: average daily support provided
  • -
  • mvpa_total: average daily total MVPA (minutes)
  • -
-
- -
-
-

Plotting provided support by partner role

-
-
support_distribution_plot <- ggplot(
-  pilot_aggregated,
-  aes(provided_emotional_support, y = after_stat(density))
-) +
-  geom_histogram(
-    bins = 15, boundary = 0,
-    fill = "steelblue", color = "white", alpha = 0.75
-  ) +
-  geom_density(
-    bounds = c(0, Inf), color = "navy", linewidth = 1.1
-  ) +
-  facet_wrap(~role, nrow = 1) +
-  labs(x = "Average provided support", y = "Density") +
-  see::theme_modern(base_size = 16)
-
- -
-
-

Provided support by partner role

- - -Histograms and boundary-corrected density curves of average provided emotional support, shown separately for female and male partners.
-
-

MVPA by partner role

- - -Histograms and boundary-corrected density curves of average daily MVPA, shown separately for female and male partners.
-
-
-

Different types of dyadic models

- -
-
-

One model dominates dyadic research

- -A horizontal bar showing that more than 85% of 998 coded dyadic studies used an APIM or APIM variant, leaving fewer than 15% for all other model specifications combined.
-

Preliminary results from an ongoing systematic review (APIM use coded for \(n = 998\) eligible articles)

-

(Sakaluk et al., 2025, p. 5).

-
- -
-
-

Many models to choose from

-

Various dyadic models can be used, each answering different questions!

-
    -
  • Actor-partner interdependence model (APIM): interdependent individuals
  • -
  • Dyad-individual model (DIM) and dyadic score model (DSM): within- and between dyad associations
  • -
  • Common fate model (CFM): latent dyadic process
  • -
-
-

Other approaches include the mutual-influence model, for reciprocal influence between partners (Iida et al., 2018, p. 61), and the Truth and Bias model, for separating mean-level bias from correlational accuracy in judgments of a partner (Kenny & Acitelli, 2001; West & Kenny, 2011).

-
- -
-
-

Many models to choose from

-

Various dyadic models can be used, each answering different questions!

-
    -
  • Actor-partner interdependence model (APIM): interdependent individuals
  • -
  • Dyad-individual model (DIM) and dyadic score model (DSM): within- and between dyad associations
  • -
  • Common fate model (CFM): latent dyadic process
  • -
-

Other approaches include the mutual-influence model, for reciprocal influence between partners (Iida et al., 2018, p. 61), and the Truth and Bias model, for separating mean-level bias from correlational accuracy in judgments of a partner (Kenny & Acitelli, 2001; West & Kenny, 2011).

- - -
-
-

The distinguishable APIM

- -Conceptual distinguishable APIM with actor and partner paths.
-

Actor and partner effects together explain some of the covariance between partners’ outcomes.

-
- - -
-
-

The distinguishable APIM

- -Conceptual distinguishable APIM with role-specific actor and partner paths.

Actor and partner effects together explain some of the covariance between partners’ outcomes. \(\rightarrow\) But some covariance may remain!

- - -
-
-

How to estimate actor and partner effects?

-

Conceptually, we are esimating these two equations in a single model:

-

\[ - \begin{gathered} - \\[0.5em] - Y_{\mathrm{male},i} - = b_{0,\mathrm{M}} + b_{1,\mathrm{M}} \times X_{\mathrm{male},i} - + b_{2,\mathrm{M}} \times X_{\mathrm{female},i} + \epsilon_{\mathrm{male},i} - \\[2em] - Y_{\mathrm{female},i} - = b_{0,\mathrm{F}} + b_{1,\mathrm{F}} \times X_{\mathrm{female},i} - + b_{2,\mathrm{F}} \times X_{\mathrm{male},i} + \epsilon_{\mathrm{female},i} - \end{gathered} -\]
Could we just use two separate models?

- -
-
-

Could we just use two separate models?

-

Male model

-
-
male_model <- glmmTMB(
-  
-  outcome_male ~ X_male + X_female,
-  
-  data = data
-)
-
-


-

Female model

-
-
female_model <- glmmTMB(
-  
-  outcome_female ~ X_female + X_male,
-  
-  data = data
-) 
-
- -
-
-

Could we just use two separate models?

-

Yes, we could! But then we:

-
    -
  • can’t test whether the two actor effects or partner effects are equal
  • -
  • can’t pool equal paths into a shared estimate, which can increase power
  • -
  • ignore unmodelled sources of interdependence between partners -
      -
    • joint modelling tells us how much interdependence remains after accounting for the predictors
    • -
  • -
- - - -
-
-

Residual interdependence in the distinguishable APIM

- -Conceptual distinguishable APIM with role-specific actor and partner paths. - -
-
-

What remains after prediction?

-
-
-
- - - - -
- -

One linked set of dyads: changing a variance rescales one partner's residuals while preserving ρεF εM; changing ρεF εM preserves both residual variances. The correlation guide is scale-free, not a fitted regression line.

-
- -
- - -
-
-

Fitting the distinguishable APIM

- -Fitted distinguishable APIM for provided support and MVPA. - -
-
-

The exchangeable APIM

-

Sometimes:

-
    -
  • partners may not be theoretically meaningfully distinguishable
  • -
  • no evidence of difference in effects \(\rightarrow\) pool effects for greater power
  • -
  • we want to formally test distinguishability
  • -
-

\(\rightarrow\) Then, we may fit an exchangeable model that imposes symmetry

- -
-
-

The exchangeable APIM

- -Conceptual exchangeable APIM with pooled actor and partner paths. - -
-
-

The exchangeable APIM

- -Conceptual exchangeable APIM with pooled actor and partner paths. - -
-
-

Exchangeability constraints

- -Distinguishable and exchangeable APIM equations, predictions, and residual constraints. - -
-
-

Fitting the exchangeable APIM

- - -Fitted exchangeable APIM for provided support and MVPA. -
-
-

Testing exchangeability

-
-
library(dyadMLM)
-
-compare_nested_glmmTMB_models(
-  exchangeable_apim,
-  distinguishable_apim
-)
-
-
Likelihood-ratio test for nested models fitted to equivalent data
-Assumes mathematical nesting and an appropriate chi-squared reference distribution.
-
-                     Df    AIC    BIC  logLik deviance  Chisq Chi Df Pr(>Chisq)
-exchangeable_apim     5 617.55 628.94 -303.78   607.55                         
-distinguishable_apim  9 611.59 632.08 -296.80   593.59 13.962      4   0.007418
-                       
-exchangeable_apim      
-distinguishable_apim **
----
-Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-
-Conclusion (5% level): The likelihood-ratio test provides evidence that `distinguishable_apim` fits better than `exchangeable_apim` (p = 0.00742).
-
-
-
-
-

The DIM

-
    -
  • A re-parametrization of the exchangeable APIM!
  • -
  • We decompose predictors into two variables: -
      -
    • Dyad mean (GM-centered): \(\bar{X} - \mu_{X}\)
    • -
    • Within-dyad member deviation: \(X_i - \bar{X}\)
    • -
  • -
-

In other words, these predictors express:

-
    -
  • A couple’s average level compared with the average of all couples
  • -
  • A partner’s level compared with the average of their couple
  • -
- - -
-
-

DIM predictors are APIM predictors in disguise!

-
-
-
- Provided support coordinates - -
- -
-
APIM coordinates
- - -
- -
-
DIM coordinates
- - -
- -
- xmean = (xactor + xpartner) / 2 - xdev = (xactorxpartner) / 2 -
-
- -
-
-
APIM
-
DIM
-
-
- -
- - APIM and DIM coordinate grid - The selected point is the grand-mean reference. - - - - - - - - -
- -
bmean = a + p
- -
bdev = ap
-

Drag the dot or move either set of sliders. Both equations give the same fitted change in MVPA.

-
-
-
- -
- -
-
-

The DIM

- -Conceptual DIM with a between-dyad path from the dyad mean and a within-dyad path from the within-dyad member deviation. - -
-
-

The DIM

- -Conceptual DIM separating the between-dyad effect of the dyad mean from the within-dyad effect of the within-dyad member deviation. - -
-
-

Why are the mean and deviation residuals uncorrelated?

- -An elevator represents the dyad mean residual, which moves both partners together; a seesaw represents the within-dyad residual, which moves partners in opposite directions. Swapping arbitrary member labels reverses only the seesaw, requiring zero covariance under exchangeability.
-

Swap the arbitrary member labels: \(r_{\mathrm{M}} \mapsto r_{\mathrm{M}} \qquad -r_{\mathrm{D}} \mapsto -r_{\mathrm{D}}\)

-
-
-

Exchangeability requires the same covariance after relabelling:

-

\[ -\operatorname{Cov}(r_{\mathrm{M}},r_{\mathrm{D}}) -= \operatorname{Cov}(r_{\mathrm{M}},-r_{\mathrm{D}}) -= -\operatorname{Cov}(r_{\mathrm{M}},r_{\mathrm{D}}) -\quad\Longrightarrow\quad -\operatorname{Cov}(r_{\mathrm{M}},r_{\mathrm{D}})=0 -\]

-
-
-

Zero does not mean independent partners: \(\operatorname{Cov}(e_1,e_2) -=\operatorname{Var}(r_{\mathrm{M}})-\operatorname{Var}(r_{\mathrm{D}})\)

-

Their residual association is encoded by the relative elevator and seesaw variances.

-
- - -
-
-

Fitting the DIM

- - -Fitted DIM for provided support and MVPA. -
-
-

DIM to APIM coefficients

-
    -
  • Once we fit an APIM, we have already fitted a DIM—and vice versa.

  • -
  • We can transform values from a fitted APIM into DIM values.

  • -
-
-
-

DIM to APIM coefficients

-

For this example, the intercept is omitted.

-

If our APIM predictor values for a focal person are: \(X_{\mathrm{self}}=1,\quad X_{\mathrm{partner}}=1\),

-

the same predictor profile in DIM coordinates is: \(X_{\mathrm{mean}}=1,\quad X_{\mathrm{dev,self}}=0.\)

-

So,

-

\[ -\hat Y_{\mathrm{self}}=1\times a+1\times p -\]

-

implies

-

\[ -\hat Y_{\mathrm{self}}=1\times b_{\mathrm{mean}}+0\times b_{\mathrm{dev}} -=b_{\mathrm{mean}}. -\]

-

Therefore,

-

\[ -b_{\mathrm{mean}}=a+p. -\]

-
-
-

DIM to APIM coefficients

-

For this example, the intercept is omitted.

-

If our APIM predictor values for a focal person are: \(X_{\mathrm{self}}=1,\quad X_{\mathrm{partner}}=-1\),

-

the same predictor profile in DIM coordinates is: \(X_{\mathrm{mean}}=0,\quad X_{\mathrm{dev,self}}=1\).

-

So,

-

\[ -\hat Y_{\mathrm{self}}=1\times a+(-1)\times p -\]

-

implies for the focal person, whose \(X_{\mathrm{self}}\) is 1 unit above the couple mean:

-

\[ -\hat Y_{\mathrm{self}}=0\times b_{\mathrm{mean}}+1\times b_{\mathrm{dev}} -=b_{\mathrm{dev}}. -\]

-

Therefore,

-

\[ -b_{\mathrm{dev}}=a-p. -\]

-
-
-

DIM to APIM coefficients

-
-
-
- Provided support coordinates - -
- -
-
APIM coordinates
- - -
- -
-
DIM coordinates
- - -
- -
- xmean = (xactor + xpartner) / 2 - xdev = (xactorxpartner) / 2 -
-
- -
-
-
APIM
-
DIM
-
-
- -
- - APIM and DIM coordinate grid - The selected point is the grand-mean reference. - - - - - - - - -
- -
bmean = a + p
- -
bdev = ap
-

Drag the dot or move either set of sliders. Both equations give the same fitted change in MVPA.

-
-
-
- -
- - -
-
-

The DSM

-

What if we want DIM-style interpretation but have distinguishable dyads?

-
-

The dyadic score model (DSM) is:

-
    -
  • the unconstrained distinguishable version of the DIM
  • -
  • a re-parametrization of the distinguishable APIM
  • -
-
-
-
    -
  • DIM: deviation from the couple mean \(X_i - \bar{X}\) -
      -
    • opposite for each partner
    • -
  • -
  • DSM: meaningful directed differences \(X_\mathrm{female} - X_\mathrm{male}\) -
      -
    • repeated for both partners.
    • -
  • -
-
- -
-
-

The DSM

- -Conceptual DSM with paths between predictor and outcome scores. - -
-
-

The DSM

- -Conceptual DSM linking predictor mean and difference to outcome mean and difference. - -
-
-

Why may the DSM residuals correlate?

- -An elevator represents the dyad mean residual, which moves both partners together; a seesaw with female and male seats represents the directed outcome-difference residual. Because these substantive labels cannot be swapped arbitrarily, the two residual components may correlate.
-

Substantive labels: \(D_Y=Y_{\mathrm{F}}-Y_{\mathrm{M}}\)

-

Swapping Female and Male changes the meaning and sign of the difference, so label-swapping is not a symmetry of the DSM.

-
-
-

\[ -\operatorname{Cov}(r_{\mathrm{M}},r_{\mathrm{D}}) -\quad\text{is not constrained to zero.} -\]

-
-
-

A positive \(\rho_{r_\mathrm{M}r_\mathrm{D}}\) means: couples whose outcomes are higher than predicted on average also tend to have a larger female–male difference than predicted.

-
- - -
-
-

Fitting the DSM

- -Fitted DSM for provided support and MVPA. -
-
-

Research Question 2

-
-
-

RQ2: In romantic couples, how is collaborative planning linked to physical activity?

-
-
-
-
-

Measurement - CFM predictor

-

Dyadic predictor: collaborative planning

-
-

Rough english translation of the original German item
“We have already planned precisely for tomorrow when, where, and how we will be physically active together.” Adapted from Scholz et al. (2008)

-
-

0 = not at all true today
to 5 = completely true today

-

We aggregate each person’s ratings into their average daily collaborative planning across the 55 days.

-
-
-

Collaborative planning by partner role

- -Histograms and boundary-corrected density curves of average collaborative planning, shown separately for female and male partners. - -
-
-

Joint MVPA by partner role

- -Histograms and boundary-corrected density curves of average daily joint MVPA, shown separately for female and male partners. - -
-
-

The CFM

- -Conceptual Common Fate Model with shared latent levels.
-
-

The CFM

- -Conceptual Common Fate Model with four observed indicator intercepts, shared latent predictor and outcome levels, and symbolic standard deviations for all four indicator residuals. -
-
-

Fitted distinguishable CFM

-
-

Constraint: \(\sigma^2_{\epsilon_{Y_F}} = \sigma^2_{\epsilon_{Y_M}}\). Without it, the estimated male outcome residual variance was negative.

-
- -Fitted Common Fate Model for collaborative planning and joint MVPA, including four observed indicator intercepts and unstandardized standard deviations for all four indicator residuals. - -
-
-

The exchangeable CFM

-

Positions 1 and 2 are arbitrary. The model must be unchanged when they are swapped (Ledermann & Macho, 2009; Peugh et al., 2013).

-

\[ -\begin{aligned} -\nu_{X_1} &= \nu_{X_2}, & \nu_{Y_1} &= \nu_{Y_2} \\ -\sigma^2_{\epsilon_{X_1}} &= \sigma^2_{\epsilon_{X_2}}, & -\sigma^2_{\epsilon_{Y_1}} &= \sigma^2_{\epsilon_{Y_2}} \\ -\operatorname{Cov}(\epsilon_{X_1},\epsilon_{Y_1}) -&= \operatorname{Cov}(\epsilon_{X_2},\epsilon_{Y_2}) -\end{aligned} -\]

-
    -
  • All four loadings remain fixed to 1.
  • -
  • Ordinary wide-data df = 6; df = 0 against the exchangeable saturated model.
  • -
  • Usual exchangeability test: \(\Delta df = 5\); here: \(\Delta df = 4\) (\(\sigma^2_{\epsilon_Y}\) is already equal).
  • -
- -
-
-

Fitted exchangeable CFM

- -Fitted exchangeable Common Fate Model for collaborative planning and joint MVPA. Female and male indicator intercepts, corresponding residual variances, and same-member residual covariances are constrained to equality.
-

No detectable loss of fit: \(\Delta\chi^2(4) = 0.65\), \(p = .958\). Parsimony favours the exchangeable model: AIC 632.60 \(\rightarrow\) 625.25; BIC 651.60 \(\rightarrow\) 637.91.

-
- - -
-
-

Honorable mention: The truth and bias model

- - - - - -
-
-

References

-
-
-Amireault, S., & Godin, G. (2015). The godin–shephard leisure-time physical activity questionnaire: Validity evidence supporting its use for classifying healthy adults into active and insufficiently active categories. Perceptual and Motor Skills, 120(2), 604–622. https://doi.org/10.2466/03.27.PMS.120v19x7 -
-
-Bolger, N., Zuckerman, A., & Kessler, R. C. (2000). Invisible support and adjustment to stress. Journal of Personality and Social Psychology, 79(6), 953–961. https://doi.org/10.1037/0022-3514.79.6.953 -
-
-Höhener, P. S., Tobias, R., Allen, J. M., Küng, P., & Scholz, U. (2026). Effectiveness of smartphone-based dyadic interventions to increase physical activity in romantic couples: Microrandomized trial. JMIR mHealth and uHealth, 14, e67136. https://doi.org/10.2196/67136 -
-
-Iida, M., Seidman, G., & Shrout, P. E. (2018). Models of interdependent individuals versus dyadic processes in relationship research. Journal of Social and Personal Relationships, 35(1), 59–88. https://doi.org/10.1177/0265407517725407 -
-
-Kenny, D. A., & Acitelli, L. K. (2001). Accuracy and bias in the perception of the partner in a close relationship. Journal of Personality and Social Psychology, 80(3), 439–448. https://doi.org/10.1037/0022-3514.80.3.439 -
-
-Kenny, D. A., & Cook, W. (1999). Partner effects in relationship research: Conceptual issues, analytic difficulties, and illustrations. Personal Relationships, 6(4), 433–448. https://doi.org/10.1111/j.1475-6811.1999.tb00202.x -
-
-Küng, P., Höhener, P. S., Allen, J. M., Tobias, R., & Scholz, U. (2026). Daily associations of three types of social control with physical activity, reactance, and mood in romantic couples: A dyadic intensive longitudinal study. Psychology & Health, 1–25. https://doi.org/10.1080/08870446.2026.2620453 -
-
-Ledermann, T., & Macho, S. (2009). Mediation in dyadic data at the level of the dyads: A structural equation modeling approach. Journal of Family Psychology, 23(5), 661–670. https://doi.org/10.1037/a0016197 -
-
-Peugh, J. L., DiLillo, D., & Panuzio, J. (2013). Analyzing mixed-dyadic data using structural equation models. Structural Equation Modeling: A Multidisciplinary Journal, 20(2), 314–337. https://doi.org/10.1080/10705511.2013.769395 -
-
-Sakaluk, J. K., Joel, S., Quinn-Nilas, C., Camanto, O. J., Pevie, N. W., Tu, E., & Jorgensen-Wells, M. A. (2025). A renewal of dyadic structural equation modeling with latent variables: Clarifications, methodological advantages, and new directions. Social and Personality Psychology Compass, 19(3), e70045. https://doi.org/10.1111/spc3.70045 -
-
-Scholz, U., Schüz, B., Ziegelmann, J. P., Lippke, S., & Schwarzer, R. (2008). Beyond behavioural intentions: Planning mediates between intentions and physical activity. British Journal of Health Psychology, 13(3), 479–494. https://doi.org/10.1348/135910707X216062 -
-
-West, T. V., & Kenny, D. A. (2011). The truth and bias model of judgment. Psychological Review, 118(2), 357–378. https://doi.org/10.1037/a0022936 -
-
-
-
-

Continue with the applied tutorial

-
-

Thank you for your attention!

-

Continue to Part II: Applied Tutorial →

-
-
-
-
-

Appendix

- -
-
-

Distinguishable APIM: residual covariance

-

Within-dyad residual covariance block (shared across dyads):

-

\[ -\operatorname{Cov} -\begin{pmatrix} -\epsilon_{Fi} \\ -\epsilon_{Mi} -\end{pmatrix} -= \boldsymbol{\Sigma}_{\epsilon} -= \begin{bmatrix} -\sigma_{\epsilon_F}^{2} -& \rho_{\epsilon_F\epsilon_M}\sigma_{\epsilon_F}\sigma_{\epsilon_M} \\ -\rho_{\epsilon_F\epsilon_M}\sigma_{\epsilon_F}\sigma_{\epsilon_M} -& \sigma_{\epsilon_M}^{2} -\end{bmatrix} -\]

-

Residual covariance matrix for all dyads (first three shown):

-

\[ -\boldsymbol{\Sigma}_{\mathrm{model}} -= \begin{bmatrix} -\boldsymbol{\Sigma}_{\epsilon} & \boldsymbol{0} & \boldsymbol{0} & \cdots \\ -\boldsymbol{0} & \boldsymbol{\Sigma}_{\epsilon} & \boldsymbol{0} & \cdots \\ -\boldsymbol{0} & \boldsymbol{0} & \boldsymbol{\Sigma}_{\epsilon} & \cdots \\ -\vdots & \vdots & \vdots & \ddots -\end{bmatrix} -\]

- -
-
-

Exchangeable APIM: residual covariance

-

For arbitrary member positions 1 and 2, the residual variances must be equal:

-

\[ -\operatorname{Cov} -\begin{pmatrix} -\epsilon_{1i} \\ -\epsilon_{2i} -\end{pmatrix} -= \boldsymbol{\Sigma}_{\epsilon,\mathrm{exch}} -= \begin{bmatrix} -\sigma_{\epsilon}^{2} -& \rho_{\epsilon_1\epsilon_2}\sigma_{\epsilon}^{2} \\ -\rho_{\epsilon_1\epsilon_2}\sigma_{\epsilon}^{2} -& \sigma_{\epsilon}^{2} -\end{bmatrix} -\]

-
    -
  • The equal diagonal elements express exchangeability.
  • -
  • The off-diagonal element still allows residual interdependence.
  • -
  • Across dyads, these blocks form the same block-diagonal model matrix as on the previous slide.
  • -
- -
-
-

DIM: residual covariance

-

\[ -\begin{aligned} -r_{\mathrm{M}i} -&= \bar{\epsilon}_i -= \frac{\epsilon_{1i}+\epsilon_{2i}}{2}, \\ -r_{\mathrm{D},mi} -&= \epsilon_{mi}-r_{\mathrm{M}i} -\quad (m=1,2), -\qquad -r_{\mathrm{D},1i} -= \frac{\epsilon_{1i}-\epsilon_{2i}}{2} -= -r_{\mathrm{D},2i}. -\end{aligned} -\]

-

Using the arbitrary orientation \(r_{\mathrm{D}i}=r_{\mathrm{D},1i}\), exchangeability gives:

-

\[ -\operatorname{Cov} -\begin{pmatrix} -r_{\mathrm{M}i} \\ -r_{\mathrm{D}i} -\end{pmatrix} -= \begin{bmatrix} -\sigma_{r_\mathrm{M}}^{2} & 0 \\ -0 & \sigma_{r_\mathrm{D}}^{2} -\end{bmatrix}. -\]

-

Back-transform to the exchangeable APIM: partner covariance need not be zero.

-
-

\[ -\begin{bmatrix} -\color{#1769AA}{\sigma_{r_\mathrm{M}}^{2}+\sigma_{r_\mathrm{D}}^{2}} -& \color{#7B3FA1}{\sigma_{r_\mathrm{M}}^{2}-\sigma_{r_\mathrm{D}}^{2}} \\[0.35em] -\color{#7B3FA1}{\sigma_{r_\mathrm{M}}^{2}-\sigma_{r_\mathrm{D}}^{2}} -& \color{#1769AA}{\sigma_{r_\mathrm{M}}^{2}+\sigma_{r_\mathrm{D}}^{2}} -\end{bmatrix} -= -\begin{bmatrix} -\color{#1769AA}{\sigma_{\epsilon}^{2}} -& \color{#7B3FA1}{\rho_{\epsilon_1\epsilon_2}\sigma_{\epsilon}^{2}} \\[0.35em] -\color{#7B3FA1}{\rho_{\epsilon_1\epsilon_2}\sigma_{\epsilon}^{2}} -& \color{#1769AA}{\sigma_{\epsilon}^{2}} -\end{bmatrix}. -\]

-
- -
-
-

DSM: residual covariance

-

With distinguishable roles, the directed difference may covary with the mean:

-

\[ -r_{\mathrm{M}i}=\frac{\epsilon_{Fi}+\epsilon_{Mi}}{2}, -\qquad -r_{\mathrm{D}i}=\epsilon_{Fi}-\epsilon_{Mi}. -\]

-

\[ -\operatorname{Cov} -\begin{pmatrix} -r_{\mathrm{M}i} \\ -r_{\mathrm{D}i} -\end{pmatrix} -= \begin{bmatrix} -\sigma_{r_\mathrm{M}}^{2} -& \rho_{r_\mathrm{M}r_\mathrm{D}} - \sigma_{r_\mathrm{M}}\sigma_{r_\mathrm{D}} \\ -\rho_{r_\mathrm{M}r_\mathrm{D}} - \sigma_{r_\mathrm{M}}\sigma_{r_\mathrm{D}} -& \sigma_{r_\mathrm{D}}^{2} -\end{bmatrix}. -\]

-

Back-transform to the distinguishable APIM, with \(c_{\mathrm{MD}} -=\rho_{r_\mathrm{M}r_\mathrm{D}} -\sigma_{r_\mathrm{M}}\sigma_{r_\mathrm{D}}\).

-
-

\[ -\begin{bmatrix} -\color{#1769AA}{ - \sigma_{r_\mathrm{M}}^{2}+\frac{1}{4}\sigma_{r_\mathrm{D}}^{2}+c_{\mathrm{MD}}} -& \color{#7B3FA1}{ - \sigma_{r_\mathrm{M}}^{2}-\frac{1}{4}\sigma_{r_\mathrm{D}}^{2}} \\[0.35em] -\color{#7B3FA1}{ - \sigma_{r_\mathrm{M}}^{2}-\frac{1}{4}\sigma_{r_\mathrm{D}}^{2}} -& \color{#B45309}{ - \sigma_{r_\mathrm{M}}^{2}+\frac{1}{4}\sigma_{r_\mathrm{D}}^{2}-c_{\mathrm{MD}}} -\end{bmatrix} -= -\begin{bmatrix} -\color{#1769AA}{\sigma_{\epsilon_F}^{2}} -& \color{#7B3FA1}{ - \rho_{\epsilon_F\epsilon_M}\sigma_{\epsilon_F}\sigma_{\epsilon_M}} \\[0.35em] -\color{#7B3FA1}{ - \rho_{\epsilon_F\epsilon_M}\sigma_{\epsilon_F}\sigma_{\epsilon_M}} -& \color{#B45309}{\sigma_{\epsilon_M}^{2}} -\end{bmatrix}. -\]

-
- - -
-
-
- - - - - - - - - - - - - - - - - - -
- Universität Zürich - - Charité – Universitätsmedizin Berlin -
-
Summer School 2026
- - - - - - - \ No newline at end of file diff --git a/dev/workshop/dyad-day.qmd b/dev/workshop/dyad-day.qmd index b2c286fa..711f8ae9 100644 --- a/dev/workshop/dyad-day.qmd +++ b/dev/workshop/dyad-day.qmd @@ -105,31 +105,27 @@ sys.source( envir = knitr::knit_global() ) -data_file <- if (file.exists("long.rds")) "long.rds" else "dev/workshop/long.rds" - -pilot <- readRDS(data_file) |> - select( - coupleID, userID, gender, ss_pa, ss_pa_min_solo, ss_pa_min_collab, - ss_emo_pleasure, sc_actionplan - ) |> - transmute( - couple_id = coupleID, - person_id = userID, - role = factor(gender, levels = c(1, 2), labels = c("female", "male")), - provided_emotional_support = ss_emo_pleasure, - collaborative_planning = sc_actionplan, - mvpa_solo = if_else(ss_pa == 0, 0, ss_pa_min_solo), - mvpa_joint = if_else(ss_pa == 0, 0, ss_pa_min_collab), - mvpa_total = mvpa_solo + mvpa_joint - ) +truth_bias_draw_file <- if ( + file.exists(file.path("R", "draw-truth-bias.R"))) { + file.path("R", "draw-truth-bias.R") +} else { + file.path("dev", "workshop", "R", "draw-truth-bias.R") +} + +sys.source( + normalizePath(truth_bias_draw_file), + envir = knitr::knit_global() +) +# Nice distribution plots ---------------------------------------------- distribution_plot <- function(data, variables, bin_widths) { labels <- c( - provided_emotional_support = "Provided emotional support", + provided_support = "Provided emotional support", + received_support = "Received emotional support", collaborative_planning = "Collaborative planning (daily mean)", - mvpa_solo = "Mean solo MVPA (minutes/day)", - mvpa_joint = "Mean joint MVPA (minutes/day)", - mvpa_total = "Mean MVPA (minutes/day)" + solo_mvpa = "Mean solo MVPA (minutes/day)", + joint_mvpa = "Mean joint MVPA (minutes/day)", + total_mvpa = "Mean MVPA (minutes/day)" ) missing_widths <- setdiff(variables, names(bin_widths)) @@ -188,22 +184,26 @@ distribution_plot <- function(data, variables, bin_widths) { -## Today's Aims and Program +## Today's aims and program + +::: {.fancy-table} | Time | Focus | |---|---| | 11:00–12:45 | Introduction and types of dyadic models | | 12:45–14:00 | *Lunch break* | -| 14:00–15:30 | Estimating cross-sectional models in R | +| 14:00–15:30 | Estimating cross-sectional dyadic models in R | | 15:30–15:45 | *Short break* | | 15:45–16:45 | Intensive longitudinal extensions | | 16:45–17:00 | *Short break* | | 17:00–18:00 | Exercises in R | +::: + # Introduction -Relevance and todays' example dataset +Relevance and today's example dataset ## Why dyadic data? @@ -215,8 +215,8 @@ Relevance and todays' example dataset *my partner's characteristics*. - **Some constructs and processes are dyadic:** Shared contexts and interdependence processes can make partners' outcomes correlated. -- **The configuration matters:** Partners' similarity, or complementarity (differences) -may predict outcomes beyond either individual score. +- **The configuration matters:** Partners' similarity or theoretically patterned +differences, such as complementarity, may predict outcomes beyond either individual score. ::: [@kennyPartnerEffectsRelationship1999; @@ -226,8 +226,8 @@ may predict outcomes beyond either individual score. ## Introducing today's dyadic dataset! -- 38 physically inactive opposite-sex romantic couples -- Both partners intended to increase their physical activity together +- 36 physically inactive romantic couples +- Both partners intended to become more physically active - Smartphone-based planning interventions and JITAIs - Daily diaries over 55 days @@ -236,11 +236,11 @@ may predict outcomes beyond either individual score. -## Research Question 1 {.rq-slide} +## Guiding question {.rq-slide} ::: {.rq-center} ::: {.rq-card} -[RQ1:]{.rq-label} [In romantic couples, how is provided health-related social support linked to physical activity?]{.rq-text} +[Guiding question:]{.rq-label} [In romantic couples, how is provided health-related social support linked to physical activity?]{.rq-text} ::: ::: @@ -248,14 +248,14 @@ may predict outcomes beyond either individual score. This is intentionally broad, since we will look at it through different lenses and analyze this with different models. -Basically answering differt sub-RQs each time that I will introduce. +Basically answering different sub-RQs each time that I will introduce. ::: -## Measurement - Predictor +## Measurement - predictor -### Emotional support provided +### Provided emotional support > **Rough English translation of the original German item**
> “How much did you emotionally support your partner today so that they would @@ -268,14 +268,15 @@ be physically active with greater enjoyment?” -## Measurement - Outcome +## Measurement - outcome ### Moderate to vigorous physical activity (MVPA) > **Rough English translation of the original German item**
> “How many minutes did you spend engaging in moderate-to-vigorous physical -activity today?” -[Adapted from @amireaultGodinShephardQuestionnaire2015]{.subtle} +> activity today?” +> +> [Adapted from @amireaultGodinShephardQuestionnaire2015]{.subtle} - **Alone:** _____ minutes - **Together with your partner:** _____ minutes @@ -284,27 +285,21 @@ activity today?” -## Aggregating for cross-sectional examples +## Person-level data for cross-sectional examples -To show simple dyadic models we aggregate the daily diary data to -obtain a "cross-sectional" dataset. +For the cross-sectional examples, we use a prepared person-level version of +the daily diary data. ```{r} -library(dplyr) - -pilot_aggregated <- pilot |> - group_by(couple_id, person_id, role) |> - summarise( - across(where(is.numeric), ~ mean(.x, na.rm = TRUE)), - .groups = "drop" - ) +pilot_aggregated <- readRDS("dyadic-person-means.rds") ``` ::: {.fragment} -The variables now represent person-level daily averages across the study: +Each row is one partner. Measures are averages across available diary days: -- `provided_emotional_support`: average daily support provided -- `mvpa_total`: average daily total MVPA (minutes) +- `provided_support`: average daily support provided +- `received_support`: average daily support received +- `total_mvpa`: average daily total MVPA (minutes) ::: @@ -318,7 +313,7 @@ The variables now represent person-level daily averages across the study: support_distribution_plot <- ggplot( pilot_aggregated, - aes(provided_emotional_support, y = after_stat(density)) + aes(provided_support, y = after_stat(density)) ) + geom_histogram( bins = 15, boundary = 0, @@ -327,7 +322,7 @@ support_distribution_plot <- ggplot( geom_density( bounds = c(0, Inf), color = "navy", linewidth = 1.1 ) + - facet_wrap(~role, nrow = 1) + + facet_wrap(~gender, nrow = 1) + labs(x = "Average provided support", y = "Density") + see::theme_modern(base_size = 16) ``` @@ -364,7 +359,7 @@ support_distribution_plot #| fig-alt: "Histograms and boundary-corrected density curves of average daily MVPA, shown separately for female and male partners." ggplot(pilot_aggregated, - aes(mvpa_total, y = after_stat(density))) + + aes(total_mvpa, y = after_stat(density))) + geom_histogram( bins = 15, boundary = 0, fill = "steelblue", color = "white", alpha = 0.75 @@ -372,7 +367,7 @@ ggplot(pilot_aggregated, geom_density( bounds = c(0, Inf), color = "navy", linewidth = 1.1 ) + - facet_wrap(~role, nrow = 1) + + facet_wrap(~gender, nrow = 1) + labs(x = "Average MVPA (minutes/day)", y = "Density") + see::theme_modern(base_size = 16) ``` @@ -424,7 +419,7 @@ ggplot(model_use) + Preliminary results from an ongoing systematic review (APIM use coded for $n = 998$ eligible articles) -[@sakalukRenewalDyadicStructural2025, p. 5]. +[@sakalukRenewalDyadicStructural2025, p. 6]. ::: @@ -434,16 +429,16 @@ $n = 998$ eligible articles) **Various dyadic models** can be used, each answering different questions! ::: {.incremental} -- **Actor-partner interdependence model (APIM)**: interdependent individuals -- **Dyad-individual model (DIM)** and **dyadic score model (DSM)**: within- and between dyad associations -- **Common fate model (CFM)**: latent dyadic process +- **Actor-partner interdependence model (APIM)**: actor and partner associations between interdependent individuals +- **Dyad-individual model (DIM)** and **dyadic score model (DSM)**: associations involving dyad levels and within-dyad differences +- **Common fate model (CFM)**: latent dyad-level constructs reflected in both partners' reports ::: -::: {.fragment} +::: {.fragment .text-smaller} Other approaches include the **mutual-influence model**, for reciprocal influence -between partners [@iidaModelsInterdependentIndividuals2018, p. 61], and the -**Truth and Bias model**, for separating mean-level bias from correlational -accuracy in judgments of a partner [@kennyAccuracyBiasPerception2001; +between partners [@iidaModelsInterdependentIndividuals2018, p. 62], and the +**Truth and Bias model**, for separating directional bias, direct accuracy, and +assumed-similarity bias in judgments of a partner [@kennyAccuracyBiasPerception2001; @westTruthBiasModel2011]. ::: @@ -453,23 +448,38 @@ accuracy in judgments of a partner [@kennyAccuracyBiasPerception2001; **Various dyadic models** can be used, each answering different questions! -- [**Actor-partner interdependence model (APIM)**: interdependent individuals]{.text-highlight} -- **Dyad-individual model (DIM)** and **dyadic score model (DSM)**: within- and between dyad associations -- **Common fate model (CFM)**: latent dyadic process +- [**Actor-partner interdependence model (APIM)**: actor and partner associations between interdependent individuals]{.text-highlight} +- **Dyad-individual model (DIM)** and **dyadic score model (DSM)**: associations involving dyad levels and within-dyad differences +- **Common fate model (CFM)**: latent dyad-level constructs reflected in both partners' reports +:::{.text-smaller} Other approaches include the **mutual-influence model**, for reciprocal influence -between partners [@iidaModelsInterdependentIndividuals2018, p. 61], and the -**Truth and Bias model**, for separating mean-level bias from correlational -accuracy in judgments of a partner [@kennyAccuracyBiasPerception2001; +between partners [@iidaModelsInterdependentIndividuals2018, p. 62], and the +**Truth and Bias model**, for separating directional bias, direct accuracy, and +assumed-similarity bias in judgments of a partner [@kennyAccuracyBiasPerception2001; @westTruthBiasModel2011]. +::: ::: {.notes} -"For broad RQ 1 we first use Actor-Partner interdependence model" +"For the guiding question, we first use the Actor-Partner Interdependence Model." ::: +# Actor-partner interdependence models +Distinguishable & exchangeable APIM + +## RQ1 · Actor and partner associations {.rq-slide} + +::: {.rq-center} +::: {.rq-card} +[RQ1:]{.rq-label} [Is a person's provided emotional support associated with (a) their own MVPA and (b) their partner's MVPA?]{.rq-text} +::: +::: + + + ## The distinguishable APIM @@ -483,7 +493,10 @@ accuracy in judgments of a partner [@kennyAccuracyBiasPerception2001; #| fig-align: center #| fig-alt: "Conceptual distinguishable APIM with actor and partner paths." -draw_apim_diagram("distinguishable", show_residuals = FALSE) +draw_apim_diagram( + "distinguishable", show_residuals = FALSE, + predictors_centered = TRUE +) ``` ::: {.fragment} @@ -512,7 +525,7 @@ outcomes. #| fig-align: center #| fig-alt: "Conceptual distinguishable APIM with role-specific actor and partner paths." -draw_apim_diagram("distinguishable") +draw_apim_diagram("distinguishable", predictors_centered = TRUE) ``` Actor and partner effects together explain some of the covariance between partners' @@ -520,13 +533,17 @@ outcomes. $\rightarrow$ But some covariance may remain! :::{.notes} But more on the residuals later!!! + +-> Ask students what grand-mean centering is. + ::: ## How to estimate actor and partner effects? -Conceptually, we are esimating these two equations in a single model: +Conceptually, we are estimating these two equations in a single model: +The member role is written first, and $i$ indexes dyads. $$ \begin{gathered} @@ -541,9 +558,12 @@ $$ \end{gathered} $$
+ [Could we just use two separate models?]{.fragment} - + + + ## Could we just use two separate models? @@ -575,19 +595,19 @@ female_model <- glmmTMB( ## Could we just use two separate models? -**Yes, we could! But then we: ** +**Yes, we could! But separate fits:** :::{.incremental} -- can't test whether the two actor effects or partner effects are equal -- can't pool equal paths into a shared estimate, which can increase power -- ignore unmodelled sources of interdependence between partners - - joint modelling tells us how much interdependence remains after accounting for the predictors +- Do not directly test whether the actor or partner effects are equal +- Do not pool equal paths into a shared estimate, which can increase power +- Do not jointly estimate residual interdependence between partners + - Joint modelling shows how much interdependence remains after accounting for the predictors ::: ::: {.bottom-reference} -[@kennyPartnerEffectsRelationship1999, pp. 439–440; -@iidaModelsInterdependentIndividuals2018, pp. 68–69] +[@kennyPartnerEffectsRelationship1999, pp. 434, 439–440; +@iidaModelsInterdependentIndividuals2018, pp. 67–69] ::: :::{.notes} @@ -612,11 +632,14 @@ within-dyad covariance is accounted for by the predictors. #| fig-align: center #| fig-alt: "Conceptual distinguishable APIM with role-specific actor and partner paths." -draw_apim_diagram("distinguishable") +draw_apim_diagram("distinguishable", predictors_centered = TRUE) ``` :::{.notes} +"This represents the two model formulas before, but in a single model with correlated +residuals." + Map the preceding visual onto the APIM notation: - Each outcome has a residual, which is what's not explained by the predictors. @@ -624,7 +647,7 @@ Map the preceding visual onto the APIM notation: partners. Their squares are the residual variances from the previous slide. - The curved double-headed arrow is the residual correlation, $\rho_{\epsilon_F\epsilon_M}$. - + ::: @@ -693,7 +716,7 @@ On the right: -## Fitting the distinguishable APIM +## Fitting the distinguishable APIM [Interpretation →](#interpreting-the-distinguishable-apim-results){.results-forward-link} {#fitting-the-distinguishable-apim} ```{r} #| label: fitted-distinguishable-apim @@ -707,8 +730,8 @@ On the right: distinguishable_apim <- fit_and_draw_distinguishable_apim( pilot_aggregated, - predictor = provided_emotional_support, - outcome = mvpa_total, + predictor = provided_support, + outcome = total_mvpa, labels = c(predictor = "Provided\nsupport", outcome = "MVPA") ) ``` @@ -721,8 +744,9 @@ distinguishable_apim <- fit_and_draw_distinguishable_apim( - All associations are conditional on both partners' provided support. -- The intercepts, 25.68 for female partners and 23.85 for male partners, are the - predicted daily MVPA when both partners' average provided support is zero. +- The intercepts, 35.28 for female partners and 31.24 for male partners, are the + predicted daily MVPA when both partners' average provided support equals the + pooled sample mean (0.92 on the original scale). - Female actor effect, -4.61: for each one-unit higher support provided by a female partner, her own predicted daily MVPA is 4.61 minutes lower, holding @@ -761,11 +785,13 @@ These are associations in the aggregated observational data, not causal effects. **Sometimes:** -- partners may not be theoretically meaningfully distinguishable -- no evidence of difference in effects $\rightarrow$ pool effects for greater power -- we want to formally test distinguishability +- Partners may not be theoretically meaningfully distinguishable +- No evidence of difference in effects $\rightarrow$ pool effects for greater power +- We want to formally test distinguishability +:::{.fragment} $\rightarrow$ Then, we may fit an exchangeable model that imposes symmetry +::: @@ -781,7 +807,10 @@ $\rightarrow$ Then, we may fit an exchangeable model that imposes symmetry #| fig-align: center #| fig-alt: "Conceptual exchangeable APIM with pooled actor and partner paths." -draw_apim_diagram("exchangeable", show_residuals = FALSE) +draw_apim_diagram( + "exchangeable", show_residuals = FALSE, + predictors_centered = TRUE +) ``` :::{.notes} @@ -809,7 +838,7 @@ pooled intercepts pooling #| fig-align: center #| fig-alt: "Conceptual exchangeable APIM with pooled actor and partner paths." -draw_apim_diagram("exchangeable") +draw_apim_diagram("exchangeable", predictors_centered = TRUE) ``` :::{.notes} @@ -842,7 +871,8 @@ draw_apim_exchangeability_comparison() :::{.notes} -In this example, imagine we have a few couples with an exactly $X_F = 1$ and $X_M = 1$. +In this example, imagine we have a few couples with exactly $X_F = 1$ and $X_M = 1$ +on the GM-centered scale. For these couples, the following would be true... On the left: @@ -876,7 +906,7 @@ On the right: -## Fitting the exchangeable APIM +## Fitting the exchangeable APIM [Interpretation →](#interpreting-the-exchangeable-apim-results){.results-forward-link} {#fitting-the-exchangeable-apim} ```{r} #| label: fitted-exchangeable-apim @@ -890,8 +920,8 @@ On the right: exchangeable_apim <- fit_and_draw_exchangeable_apim( pilot_aggregated, - predictor = provided_emotional_support, - outcome = mvpa_total, + predictor = provided_support, + outcome = total_mvpa, labels = c(predictor = "Provided\nsupport", outcome = "MVPA") ) ``` @@ -911,26 +941,68 @@ exchangeable_apim <- fit_and_draw_exchangeable_apim( ```{r} library(dyadMLM) -compare_nested_glmmTMB_models( +compare_nested_models( exchangeable_apim, distinguishable_apim ) ``` +# Level-and-difference models +Dyad-individual model & dyadic score model +## Shifting the analytical lens -## The DIM +Sometimes, actor and partner associations are not the primary interest. + +Instead, we may want to understand: + +- How couples compare with other couples +- How partners stand relative to one another within a couple + +::: {.fragment} + +This shifts the focus to **dyadic levels and within-dyad differences**. + +::: + +::: {.fragment} + + - For exchangeable dyads, use the **dyad-individual model (DIM)** + - For distinguishable dyads, use the **dyadic score model (DSM)** + +::: + + + +## RQ2 · Dyad levels and differences {.rq-slide} + +::: {.rq-center} +::: {.rq-card} +[RQ2:]{.rq-label} [How are couples' average levels and partner differences in provided emotional support associated with the couple-average MVPA and partner differences in MVPA?]{.rq-text} +::: +::: + + + + +## The dyad-individual model (DIM) + +**The DIM is:** - A re-parametrization of the **exchangeable** APIM! - We decompose predictors into two variables: - Dyad mean (GM-centered): $\bar{X} - \mu_{X}$ - Within-dyad member deviation: $X_i - \bar{X}$ - + +:::{.fragment} + In other words, these predictors express: - A couple's average level compared with the average of all couples - A partner's level compared with the average of their couple +::: + :::{.notes} So, you can see how this would answer different research questions than an @@ -1094,7 +1166,7 @@ IS exactly equivalent to the APIM -## Fitting the DIM +## Fitting the DIM [Interpretation →](#interpreting-the-fitted-dim-results){.results-forward-link} {#fitting-the-dim} ```{r} #| label: fitted-dim @@ -1108,8 +1180,8 @@ IS exactly equivalent to the APIM fit_and_draw_dim( pilot_aggregated, - predictor = provided_emotional_support, - outcome = mvpa_total, + predictor = provided_support, + outcome = total_mvpa, labels = c(predictor = "support", outcome = "MVPA") ) ``` @@ -1126,31 +1198,31 @@ we fit the DIM here with the same data and variables to demonstrate. -> Why no intercept? for the deviation? -No intercept for the MVPA deviation, because that would break exchangeability. -if support deviation is zero, then the expected MVPA deviation is also zero. - --> We conceptually DO have an intercept, it is just constrained to be ZERO! - --> just like the correlation between the residuals, they are not estimated, which -effectively constrains them to be zero. - + No intercept for the MVPA deviation, because that would break exchangeability. + if support deviation is zero, then the expected MVPA deviation is also zero. + + -> We conceptually DO have an intercept, it is just constrained to be ZERO! + + -> just like the correlation between the residuals, they are not estimated, which + effectively constrains them to be zero. + ::: -## DIM to APIM coefficients +## DIM to exchangeable APIM coefficients - Once we fit an APIM, we have already fitted a DIM—and vice versa. - We can transform values from a fitted APIM into DIM values. -## DIM to APIM coefficients {.compact-derivation} +## DIM to exchangeable APIM coefficients {.compact-derivation} -[For this example, the intercept is omitted.]{.derivation-context} +[The intercept is omitted; APIM predictors are grand-mean centered.]{.derivation-context} -If our APIM predictor values for a focal person are: +For a focal person, let $X_{\mathrm{self}}=1,\quad X_{\mathrm{partner}}=1$, -the same predictor profile in DIM coordinates is: +so that in DIM coordinates: $X_{\mathrm{mean}}=1,\quad X_{\mathrm{dev,self}}=0.$ So, @@ -1172,14 +1244,14 @@ $$ b_{\mathrm{mean}}=a+p. $$ -## DIM to APIM coefficients {.compact-derivation} +## DIM to exchangeable APIM coefficients {.compact-derivation} -[For this example, the intercept is omitted.]{.derivation-context} +[The intercept is omitted; APIM predictors are grand-mean centered.]{.derivation-context} -If our APIM predictor values for a focal person are: +For a focal person, let $X_{\mathrm{self}}=1,\quad X_{\mathrm{partner}}=-1$, -the same predictor profile in DIM coordinates is: +so that in DIM coordinates: $X_{\mathrm{mean}}=0,\quad X_{\mathrm{dev,self}}=1$. So, @@ -1188,8 +1260,7 @@ $$ \hat Y_{\mathrm{self}}=1\times a+(-1)\times p $$ -implies for the focal person, whose $X_{\mathrm{self}}$ is 1 unit above the -couple mean: +implies: $$ \hat Y_{\mathrm{self}}=0\times b_{\mathrm{mean}}+1\times b_{\mathrm{dev}} @@ -1203,7 +1274,7 @@ b_{\mathrm{dev}}=a-p. $$ -## DIM to APIM coefficients +## DIM to exchangeable APIM coefficients ```{r} #| label: interactive-apim-dim-grid-coefficients @@ -1223,22 +1294,22 @@ dim_reparameterization_grid( -## The DSM +## The dyadic score model (DSM) What if we want DIM-style interpretation but have distinguishable dyads? :::{.fragment} -### The dyadic score model (DSM) is: +**The DSM is:** -- the unconstrained distinguishable version of the DIM -- a re-parametrization of the distinguishable APIM +- The unconstrained distinguishable version of the DIM +- A re-parametrization of the distinguishable APIM ::: :::{.fragment} - **DIM**: deviation from the couple mean $X_i - \bar{X}$ - opposite for each partner - **DSM**: meaningful directed differences $X_\mathrm{female} - X_\mathrm{male}$ - - repeated for both partners. + - repeated for both partners ::: @@ -1359,7 +1430,7 @@ difference than predicted. -## Fitting the DSM +## Fitting the DSM [Interpretation →](#interpreting-the-fitted-dsm-results){.results-forward-link} {#fitted-dsm-results} ```{r} #| label: fitted-dsm @@ -1373,8 +1444,8 @@ difference than predicted. fit_and_draw_dsm( pilot_aggregated, - predictor = provided_emotional_support, - outcome = mvpa_total, + predictor = provided_support, + outcome = total_mvpa, labels = c(predictor = "support", outcome = "MVPA") ) ``` @@ -1384,31 +1455,98 @@ fit_and_draw_dsm( -> students interpret results, including correlation. -**Intercepts**: A couple with *average mean level* and *zero male-female difference* is expected to be: +**Intercepts**: For a couple with an average support mean and no female–male support difference: -- a10: 33.26 min more active on average, -- a20: have a female that is 4.04 min more active than the male. +- a10: predicted couple-mean MVPA is 33.26 minutes, +- a20: the female is predicted to be 4.04 min more active than the male. -A couple providing 1 unit more average support is expected to be: +Holding the couple-difference score at zero, +**a 1 unit higher couple-mean support score** is associated with: -- a11: 9.25 minutes more active on average, -- a21: have a female that is 2.4 minutes + 4.04 minutes more active than the male +- a11: 9.25 additional minutes of couple-mean MVPA, +- a21: a 2.4-minute larger female-male MVPA difference (The female is 2.4 minutes + 4.04 minutes more active than the male). -A couple with a female providing 1 unit more support than the male is expected to: +Holding the couple-mean score at the *sample-average*, +**a one-unit larger female-male support difference** is associated with: -- a12: have a couple-mean MVPA 11.86 minutes lower. -- a22: have a female that is 4.06 minutes + 4.04 minutes more active than the male +- a12: 11.86 fewer minutes of couple-mean MVPA +- a22: a 4.06-minute larger female-male MVPA difference (The female is 4.06 minutes + 4.04 minutes more active than the male) - +**Residual correlations** + +After accounting for the support mean and female–male support difference, +couples whose average MVPA is higher than predicted also tend to have a more +positive female–male MVPA difference than predicted. + +In other words, their unexplained MVPA tends to tilt toward the female partner. ::: -## Research Question 2 {.rq-slide} + +## DSM to distinguishable APIM coefficients {.smaller} + +- Once we fit a DSM, we have already fitted a distinguishable APIM—and vice versa. + +- We can back-transform the DSM fixed effects into APIM coefficients: + +$$ +\begin{aligned} +b_{0,\mathrm F} + &=a_{10}+\tfrac12a_{20}, +& +b_{0,\mathrm M} + &=a_{10}-\tfrac12a_{20},\\[0.4em] +b_{1,\mathrm F} + &=\tfrac12a_{11}+a_{12}+\tfrac14a_{21}+\tfrac12a_{22}, +& +b_{1,\mathrm M} + &=\tfrac12a_{11}-a_{12}-\tfrac14a_{21}+\tfrac12a_{22},\\[0.4em] +b_{2,\mathrm F} + &=\tfrac12a_{11}-a_{12}+\tfrac14a_{21}-\tfrac12a_{22}, +& +b_{2,\mathrm M} + &=\tfrac12a_{11}+a_{12}-\tfrac14a_{21}-\tfrac12a_{22}. +\end{aligned} +$$ + +Here, $b_1$ is the actor effect and $b_2$ is the partner effect. The APIM +predictors and DSM couple mean now use the same pooled grand-mean reference, so +no additional centering adjustment is needed for the intercepts. + +# Common fate model +Modeling dyadic constructs + +## When the construct is dyadic + +Sometimes, a construct describes the **couple as a unit**, rather than either +partner individually. + +- Both partners report on the same dyadic phenomenon. +- Differences between their reports are not the substantive focus. +- Interest lies in the couple's underlying dyadic level. + +:::{.fragment} + +**For our data example:** + +- Collaborative planning as a dyadic predictor +- Joint physical activity as a dyadic outcome + +::: + + + +:::{.notes} + +-> Ask students if they had ideas on a dyadic construct + +::: + +## RQ3 · Shared dyadic constructs {.rq-slide} ::: {.rq-center} ::: {.rq-card} -[RQ2:]{.rq-label} [In romantic couples, how is collaborative planning linked to physical -activity?]{.rq-text} +[RQ3:]{.rq-label} [How is collaborative planning associated with joint physical activity in romantic couples?]{.rq-text} ::: ::: @@ -1416,96 +1554,85 @@ activity?]{.rq-text} ### Dyadic predictor: collaborative planning -> **Rough english translation of the original German item**
+> **Rough English translation of the original German item**
> “We have already planned precisely for tomorrow when, where, and how we will -be physically active together.” -[Adapted from @scholzBeyondBehaviouralIntentions2008]{.subtle} +> be physically active together.” +> +> [Adapted from @scholzBeyondBehaviouralIntentions2008]{.subtle} 0 = *not at all true today*
-to 5 = *completely true today* +5 = *completely true today* We aggregate each person's ratings into their **average daily collaborative planning** across the 55 days. -## Collaborative planning by partner role +## Do partners report similar dyadic levels? ```{r} -#| label: pilot-planning-distributions-by-role +#| label: cfm-partner-agreement #| echo: false #| dev: svglite #| fig-width: 12 #| fig-height: 5.1 #| out-width: 100% #| fig-align: center -#| fig-alt: "Histograms and boundary-corrected density curves of average collaborative planning, shown separately for female and male partners." +#| fig-alt: "Partner-agreement plots for collaborative planning and joint MVPA, with female reports on the horizontal axis, male reports on the vertical axis, and diagonal identity lines." -ggplot(pilot_aggregated, - aes(collaborative_planning, y = after_stat(density))) + - geom_histogram( - bins = 15, boundary = 0, - fill = "steelblue", color = "white", alpha = 0.75 - ) + - geom_density( - bounds = c(0, Inf), color = "navy", linewidth = 1.1 +cfm_data <- pilot_aggregated |> + group_by(couple_id) |> + filter(n_distinct(gender) == 2) |> + ungroup() |> + select(couple_id, gender, collaborative_planning, joint_mvpa) |> + tidyr::pivot_wider( + names_from = gender, + values_from = c(collaborative_planning, joint_mvpa), + names_sep = "_" + ) + +planning_agreement_plot <- ggplot( + cfm_data, + aes(collaborative_planning_female, collaborative_planning_male) +) + + geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "grey55") + + geom_point(color = "steelblue", size = 2.4, alpha = 0.8) + + coord_equal() + + labs( + title = "Collaborative planning (0–5)", + x = "Female report", + y = "Male report" ) + - facet_wrap(~role, nrow = 1) + - labs(x = "Average collaborative planning", y = "Density") + see::theme_modern(base_size = 16) -``` -:::{.notes} - -- Each panel shows a partner's average daily collaborative planning across the - study. -- The shared axes allow direct comparison of the two role-specific - distributions. -- These are descriptive role differences, not evidence that the CFM parameters - differ by role. - -::: - - - -## Joint MVPA by partner role - -```{r} -#| label: pilot-joint-mvpa-distributions-by-role -#| echo: false -#| dev: svglite -#| fig-width: 12 -#| fig-height: 5.1 -#| out-width: 100% -#| fig-align: center -#| fig-alt: "Histograms and boundary-corrected density curves of average daily joint MVPA, shown separately for female and male partners." - -ggplot(pilot_aggregated, - aes(mvpa_joint, y = after_stat(density))) + - geom_histogram( - bins = 15, boundary = 0, - fill = "steelblue", color = "white", alpha = 0.75 - ) + - geom_density( - bounds = c(0, Inf), color = "navy", linewidth = 1.1 +mvpa_agreement_plot <- ggplot( + cfm_data, + aes(joint_mvpa_female, joint_mvpa_male) +) + + geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "grey55") + + geom_point(color = "steelblue", size = 2.4, alpha = 0.8) + + coord_equal() + + labs( + title = "Joint MVPA (minutes/day)", + x = "Female report", + y = "Male report" ) + - facet_wrap(~role, nrow = 1) + - labs(x = "Average joint MVPA (minutes/day)", y = "Density") + see::theme_modern(base_size = 16) + +patchwork::wrap_plots(planning_agreement_plot, mvpa_agreement_plot) ``` :::{.notes} -- Each panel shows person-level average daily MVPA performed jointly with the - partner. -- Both roles share the same axes and each dyad contributes one person to each - panel. -- The distributions are descriptive inputs to the subsequent common fate - model. +- Each point is one couple; the diagonal indicates identical partner reports. +- The partners need not report exactly the same value. The CFM treats both + reports as imperfect indicators of an underlying dyadic level. +- Marginal distributions alone would not show the within-couple correspondence + that motivates the CFM. ::: -## The CFM +## The distinguishable CFM ```{r} #| label: conceptual-cfm-paths-only @@ -1515,12 +1642,16 @@ ggplot(pilot_aggregated, #| fig-height: 5.8 #| out-width: 100% #| fig-align: center -#| fig-alt: "Conceptual Common Fate Model with shared latent levels." +#| fig-alt: "Conceptual distinguishable Common Fate Model with female and male reports as indicators of shared latent levels." -draw_cfm_diagram(show_residuals = FALSE) +draw_cfm_diagram( + show_residuals = FALSE, + member_ids = c("F", "M"), + member_names = c("Female", "Male") +) ``` -## The CFM +## The distinguishable CFM ```{r} #| label: conceptual-cfm @@ -1530,17 +1661,21 @@ draw_cfm_diagram(show_residuals = FALSE) #| fig-height: 5.8 #| out-width: 100% #| fig-align: center -#| fig-alt: "Conceptual Common Fate Model with four observed indicator intercepts, shared latent predictor and outcome levels, and symbolic standard deviations for all four indicator residuals." +#| fig-alt: "Conceptual distinguishable Common Fate Model with female and male indicator intercepts, shared latent predictor and outcome levels, and symbolic standard deviations for all four indicator residuals." -draw_cfm_diagram() +draw_cfm_diagram( + member_ids = c("F", "M"), + member_names = c("Female", "Male") +) ``` :::{.notes} -- The intercepts are measurement intercepts. The expected values of each members' report -when the corresponding latent dyad level is zero. - - because latent means are fixed to zero (as a reference point) they represent the mean reported values. +- The intercepts are measurement intercepts: the expected values of each member's + report when the corresponding latent dyad level is zero. + - Because latent means are fixed to zero (as a reference point), they represent + the mean reported values. - Member 1 and Member 2 may be meaningful, **distinguishable** roles, such as female and male. @@ -1554,9 +1689,8 @@ when the corresponding latent dyad level is zero. ## Fitted distinguishable CFM ::: {.cfm-constraint} -**Constraint:** -$\sigma^2_{\epsilon_{Y_F}} = \sigma^2_{\epsilon_{Y_M}}$. -Without it, the estimated male outcome residual variance was negative. +**Model constraint:** The female and male joint-MVPA residual variances were +constrained equal to obtain admissible fit. ::: ```{r} @@ -1569,36 +1703,25 @@ Without it, the estimated male outcome residual variance was negative. #| fig-align: center #| fig-alt: "Fitted Common Fate Model for collaborative planning and joint MVPA, including four observed indicator intercepts and unstandardized standard deviations for all four indicator residuals." -cfm_data <- pilot_aggregated |> - group_by(couple_id) |> - filter(n_distinct(role) == 2) |> - ungroup() |> - select(couple_id, role, collaborative_planning, mvpa_joint) |> - tidyr::pivot_wider( - names_from = role, - values_from = c(collaborative_planning, mvpa_joint), - names_sep = "_" - ) - distinguishable_cfm_model <- ' # Shared dyad levels: fix all four loadings to 1. planning_level =~ 1 * collaborative_planning_female + 1 * collaborative_planning_male joint_mvpa_level =~ - 1 * mvpa_joint_female + - 1 * mvpa_joint_male + 1 * joint_mvpa_female + + 1 * joint_mvpa_male # Association between the two shared levels. joint_mvpa_level ~ b_level * planning_level # Same-member residual covariances. - collaborative_planning_female ~~ c_female * mvpa_joint_female - collaborative_planning_male ~~ c_male * mvpa_joint_male + collaborative_planning_female ~~ c_female * joint_mvpa_female + collaborative_planning_male ~~ c_male * joint_mvpa_male # Both partners report the same jointly performed activity. - mvpa_joint_female ~~ e_mvpa * mvpa_joint_female - mvpa_joint_male ~~ e_mvpa * mvpa_joint_male + joint_mvpa_female ~~ e_mvpa * joint_mvpa_female + joint_mvpa_male ~~ e_mvpa * joint_mvpa_male ' workshop_distinguishable_cfm <- lavaan::sem( @@ -1633,49 +1756,33 @@ draw_cfm_diagram( -## The exchangeable CFM - -Positions 1 and 2 are arbitrary. The model must be unchanged when they are -swapped [@ledermannMediationDyadicData2009; @peughAnalyzingMixedDyadic2013]. +## When should we model a CFM as exchangeable? -$$ -\begin{aligned} -\nu_{X_1} &= \nu_{X_2}, & \nu_{Y_1} &= \nu_{Y_2} \\ -\sigma^2_{\epsilon_{X_1}} &= \sigma^2_{\epsilon_{X_2}}, & -\sigma^2_{\epsilon_{Y_1}} &= \sigma^2_{\epsilon_{Y_2}} \\ -\operatorname{Cov}(\epsilon_{X_1},\epsilon_{Y_1}) -&= \operatorname{Cov}(\epsilon_{X_2},\epsilon_{Y_2}) -\end{aligned} -$$ +:::{.incremental} +- Partner positions are arbitrary, or theory and the data support treating the + measurement process as invariant across roles. +- Swapping the partner labels should then leave the model unchanged. +- We constrain corresponding partner parameters to be equal: + - **intercepts:** the same expected report level + - **residual variances:** the same amount of indicator-specific variation + - **same-member residual associations:** the same residual predictor–outcome + association for both partners + +::: -- All four loadings remain fixed to 1. -- Ordinary wide-data **df = 6**; **df = 0** against the exchangeable saturated - model. -- Usual exchangeability test: $\Delta df = 5$; here: $\Delta df = 4$ - ($\sigma^2_{\epsilon_Y}$ is already equal). +[@ledermannMediationDyadicData2009; @peughAnalyzingMixedDyadic2013]{.subtle} :::{.notes} -- Equality is imposed on the two same-member residual covariances. Because the - corresponding residual variances are also equal, the residual correlations - are equal as a consequence. -- `lavaan` reports 6 degrees of freedom because its default saturated reference - model is fully unrestricted. Six observed-moment restrictions are required - for exchangeability. -- The exchangeable CFM reproduces the exchangeable saturated model, so it has - zero degrees of freedom relative to that appropriate reference model. Its - ordinary chi-square is therefore a test of exchangeability, not an additional - test of the basic CFM structure. -- An unconstrained distinguishable CFM has df = 1, giving the usual five-degree- - of-freedom exchangeability test. Our distinguishable model already equates the - two outcome residual variances and has df = 2, so the comparison on the next - slide tests the four remaining equality constraints. -- A well-fitting constrained model does not make substantively meaningful roles - exchangeable; that decision must also follow the research question. +- Equality constraints express the assumption that the measurement process does + not depend on which arbitrary partner position receives a report. +- A well-fitting constrained model does not by itself make substantively + meaningful roles exchangeable; the decision must also follow the design and + research question. ::: -## Fitted exchangeable CFM +## Fitted CFM with partner-role equality constraints ```{r} #| label: fitted-exchangeable-cfm @@ -1693,8 +1800,8 @@ exchangeable_cfm_model <- ' 1 * collaborative_planning_female + 1 * collaborative_planning_male joint_mvpa_level =~ - 1 * mvpa_joint_female + - 1 * mvpa_joint_male + 1 * joint_mvpa_female + + 1 * joint_mvpa_male # Association between the two shared levels. joint_mvpa_level ~ b_level * planning_level @@ -1702,18 +1809,18 @@ exchangeable_cfm_model <- ' # Equal indicator intercepts across positions. collaborative_planning_female ~ i_planning * 1 collaborative_planning_male ~ i_planning * 1 - mvpa_joint_female ~ i_mvpa * 1 - mvpa_joint_male ~ i_mvpa * 1 + joint_mvpa_female ~ i_mvpa * 1 + joint_mvpa_male ~ i_mvpa * 1 # Equal residual variances across positions. collaborative_planning_female ~~ e_planning * collaborative_planning_female collaborative_planning_male ~~ e_planning * collaborative_planning_male - mvpa_joint_female ~~ e_mvpa * mvpa_joint_female - mvpa_joint_male ~~ e_mvpa * mvpa_joint_male + joint_mvpa_female ~~ e_mvpa * joint_mvpa_female + joint_mvpa_male ~~ e_mvpa * joint_mvpa_male # Equal same-member residual covariances across positions. - collaborative_planning_female ~~ c_female * mvpa_joint_female - collaborative_planning_male ~~ c_male * mvpa_joint_male + collaborative_planning_female ~~ c_female * joint_mvpa_female + collaborative_planning_male ~~ c_male * joint_mvpa_male c_female == c_male ' @@ -1733,19 +1840,6 @@ cfm_chisq_difference <- cfm_model_comparison$`Chisq diff`[2] cfm_df_difference <- cfm_model_comparison$`Df diff`[2] cfm_comparison_p <- cfm_model_comparison$`Pr(>Chisq)`[2] -cfm_distinguishable_aic <- lavaan::fitMeasures( - workshop_distinguishable_cfm, "aic" -) -cfm_exchangeable_aic <- lavaan::fitMeasures( - workshop_exchangeable_cfm, "aic" -) -cfm_distinguishable_bic <- lavaan::fitMeasures( - workshop_distinguishable_cfm, "bic" -) -cfm_exchangeable_bic <- lavaan::fitMeasures( - workshop_exchangeable_cfm, "bic" -) - draw_cfm_diagram( model = workshop_exchangeable_cfm, parameter_labels = c( @@ -1759,25 +1853,29 @@ draw_cfm_diagram( outcome_name = "joint MVPA", show_standardized_effect = FALSE ) + +cfm_level_estimate <- lavaan::parameterEstimates( + workshop_exchangeable_cfm +) |> + filter(label == "b_level") |> + pull(est) + +cfm_level_r2 <- lavaan::lavInspect( + workshop_exchangeable_cfm, "rsquare" +)[["joint_mvpa_level"]] ``` ::: {.cfm-constraint} -**No detectable loss of fit:** +**Likelihood-ratio test of the remaining partner-role equality constraints:** $\Delta\chi^2(`r cfm_df_difference`) = `r sprintf("%.2f", cfm_chisq_difference)`$, -$p = `r sub("^0", "", sprintf("%.3f", cfm_comparison_p))`$. -**Parsimony favours the exchangeable model:** -AIC `r sprintf("%.2f", cfm_distinguishable_aic)` $\rightarrow$ -`r sprintf("%.2f", cfm_exchangeable_aic)`; -BIC `r sprintf("%.2f", cfm_distinguishable_bic)` $\rightarrow$ -`r sprintf("%.2f", cfm_exchangeable_bic)`. +$p = `r sub("^0", "", sprintf("%.3f", cfm_comparison_p))`$; no detectable loss +of fit. ::: :::{.notes} - The four additional equality constraints fit the data very well. The likelihood-ratio test provides no evidence that they worsen fit. -- AIC and BIC are lower for the exchangeable model because it achieves almost - the same likelihood with four fewer free parameters. - This is evidence that pooling the female and male measurement parameters is compatible with this small sample; it does not establish that gender is substantively irrelevant or that the partners were arbitrarily assigned. @@ -1787,44 +1885,218 @@ BIC `r sprintf("%.2f", cfm_distinguishable_bic)` $\rightarrow$ +## RQ3 result {.rq-slide} + +::: {.rq-center} + +> **RQ3:** In this small observational sample, a one-unit higher latent +> collaborative-planning level was associated with +> `r sprintf("%.2f", cfm_level_estimate)` more minutes of joint MVPA per day at +> the couple level ($R^2 = `r sprintf("%.2f", cfm_level_r2)`$). + +::: + + +:::{.notes} -## Honorable mention: The truth and bias model +- Here, $R^2 = `r sprintf("%.2f", cfm_level_r2)`$ means that collaborative + planning, the model's only predictor, accounts for + `r sprintf("%.0f", 100 * cfm_level_r2)`% of the total model-implied variance + across couples in the **latent joint-MVPA level**. It does not refer to the + total variance in the two observed partner reports. +- This is an outcome-specific, model-based descriptive summary—not an overall + fit measure or evidence of a causal effect. - +::: + + +# Other interesting dyadic models to consider + +## Other dyadic models and designs {.smaller} + +- **Truth and Bias model:** Separates direct accuracy in judging a partner from + directional bias and assumed-similarity bias [@westTruthBiasModel2011]. + +- **Mutual-influence model:** Tests whether partners' outcomes directly and + reciprocally influence one another [@kennyModelsNonIndependenceDyadic1996]. + +- **APIM mediation model:** Traces whether actor and partner associations operate + through either partner's mediator [@ledermannAssessingMediationDyadic2011]. + +- **Dyadic response surface analysis:** Tests whether partner similarity, + discrepancy, or particular combinations of scores relate to an outcome + [@schonbrodtTestingSimilarityEffects2018]. + +- **One-with-many and Social Relations models:** Extend dyadic analysis to + repeated relationships with several partners or round-robin groups, separating + person and relationship components + [@kenny2006dyadic; @kennySocialRelationsModel1984]. + +- **Network models:** Explain the formation and evolution of ties within an + interconnected group, including reciprocity, transitivity, and actor-oriented + network change [@hollandExponentialFamilyDirected1981; + @snijdersStatisticalEvaluationNetwork2001]. + + + +```{r} +#| label: fit-truth-bias +#| include: false + +truth_bias_fit_file <- if ( + file.exists(file.path("R", "fit-truth-bias.R"))) { + file.path("R", "fit-truth-bias.R") +} else { + file.path("dev", "workshop", "R", "fit-truth-bias.R") +} + +sys.source( + normalizePath(truth_bias_fit_file), + envir = knitr::knit_global() +) + +truth_bias_result <- fit_truth_bias(pilot_aggregated) +``` + +## The Truth and Bias model [[@kennyAccuracyBiasPerception2001; @westTruthBiasModel2011]]{.heading-reference} {#the-truth-and-bias-model} + +```{r} +#| label: fitted-truth-bias +#| echo: false +#| dev: svg +#| fig-width: 9 +#| fig-height: 4.8 +#| out-width: 90% +#| fig-align: center +#| fig-alt: "Fitted dyadic Truth and Bias model for provided and received emotional support. Estimates and significance stars annotate female- and male-specific assumed-similarity, direct-accuracy, and directional-bias paths. The partners' provided-support correlation represents actual similarity, and received-support judgment residuals covary." + +draw_truth_bias_diagram(truth_bias_result) +``` + +::: {.text-smaller} + +- The partner's report is the researcher-defined “truth”, not necessarily +an objective truth. + +- After truth-mean centering, $b_0$ is **directional bias**. + +::: + +:::{.notes} + +- Received support is the judgment; the partner's provided support is the + operational “truth”; one's own provision is the assumed-similarity predictor. +- **Intercept:** At average provision by both partners, does the perceiver report + receiving more or less than the partner reports providing? +- **Slopes:** Does perceived support track the partner's provision (direct + accuracy) or one's own provision (assumed similarity)? +- The correlation between partners' provision is actual similarity, which lets + assumed similarity contribute indirectly to accuracy. +- Here, assumed similarity was strong; direct accuracy was positive for female + perceivers but not evident for male perceivers. Treat this small, + cross-sectional example descriptively. + +::: +```{r} +#| label: fit-dyadic-response-surface +#| include: false + +drsa_fit_file <- if ( + file.exists(file.path("R", "fit-dyadic-response-surface.R"))) { + file.path("R", "fit-dyadic-response-surface.R") +} else { + file.path("dev", "workshop", "R", "fit-dyadic-response-surface.R") +} +drsa_draw_file <- if ( + file.exists(file.path("R", "draw-dyadic-response-surface.R"))) { + file.path("R", "draw-dyadic-response-surface.R") +} else { + file.path("dev", "workshop", "R", "draw-dyadic-response-surface.R") +} - +```{r} +#| label: fitted-dyadic-response-surface +#| echo: false +#| dev: svglite +#| fig-width: 12 +#| fig-height: 4.65 +#| out-width: 100% +#| fig-align: center +#| fig-alt: "Two fitted response surfaces from one joint dyadic polynomial model. Each shows predicted female or male average daily total MVPA as a function of female-provided and male-provided emotional support centered at the pooled mean. Points and loops mark the observed couples and predictor region; the solid blue line is the line of congruence and the dashed purple line is the line of incongruence." - +- **[Line of incongruence]{style="color: #7B3FA1"}** curves upward; no clear slope or curvature along the **[line of congruence]{style="color: #1769AA"}**. - + +## Q&A and discussion + +Questions? + +:::{.fragment} + +- Discuss the different approaches briefly with your neighbor: which ones +might be most relevant for your own data/research questions? (ca. 5 min) + +- Share with the group. + +::: + + + +# Prepare for later exercises in R + +- Go to [https://pascal-kueng.github.io/dyadMLM/workshop/](https://pascal-kueng.github.io/dyadMLM/workshop/) +- Link is also in the Teams channel +- Download and unzip all workshop materials +- Start R from that folder (by opening one of the files) + +Run this in the console to ensure all relevant packages are installed and up to date: + +```{r eval = FALSE} +source("00_setup.R") +``` -Create exercises with data visalization, etc. Panel plots, histograms -correlations (wb corr)? ---> ## References @@ -1844,6 +2116,146 @@ Thank you for your attention! # Appendix +## Interpreting the distinguishable APIM [← Results](#fitting-the-distinguishable-apim){.appendix-back-link} {.smaller .interpretation-slide} + +::: {.interpretation-footnote} +Red estimates are not statistically distinguishable from zero at +$\alpha = .05$. Their numerical translations are shown only to demonstrate how +APIM coefficients are interpreted; they should not be treated as evidence of a +nonzero effect. +::: + +**Intercepts:** When both partners' support scores equal the pooled sample mean: + +- $b_{0,\mathrm{F}}$: Predicted female MVPA is 35.28 minutes. +- $b_{0,\mathrm{M}}$: Predicted male MVPA is 31.24 minutes. + +**Female MVPA**, holding the male partner's support constant: + +- [$a_{\mathrm{F}}$: One-unit higher female support is associated with 4.61 fewer minutes of her own MVPA.]{.not-significant} +- $p_{\mathrm{F}}$: One-unit higher male support is associated with 15.06 additional minutes of female MVPA. + +**Male MVPA**, holding the female partner's support constant: + +- $a_{\mathrm{M}}$: One-unit higher male support is associated with 17.92 additional minutes of his own MVPA. +- [$p_{\mathrm{M}}$: One-unit higher female support is associated with 9.87 fewer minutes of male MVPA.]{.not-significant} + +**Residual correlation ($\rho = .78$):** When the female's MVPA is higher than predicted, the male's MVPA also tends to be higher than predicted, and likewise for being lower. This is the remaining within-couple interdependence after accounting for both support scores. + +## Interpreting the exchangeable APIM [← Results](#fitting-the-exchangeable-apim){.appendix-back-link} {.smaller .interpretation-slide} + +::: {.interpretation-footnote} +Red estimates are not statistically distinguishable from zero at +$\alpha = .05$. Their numerical translations are shown only to demonstrate how +APIM coefficients are interpreted; they should not be treated as evidence of a +nonzero effect. +::: + +The intercept, actor effect, partner effect, and residual SD are **pooled across members**. + +**Pooled intercept:** When both partners' support scores equal the pooled sample mean: + +- $b_0$: Predicted MVPA is 31.21 minutes for either member position. + +**Pooled effects:** For either member, holding the other support score constant: + +- $a$: One-unit higher own support is associated with 7.75 additional minutes of own MVPA. +- [$p$: One-unit higher partner support is associated with 1.97 additional minutes of own MVPA.]{.not-significant} + +Pooling means that the same coefficients are used for both member positions. It does not require the two members to have identical predictions because their own and partner support scores may differ. + +**Residual correlation ($\rho = .77$):** When one member's MVPA is higher than predicted, the partner's MVPA also tends to be higher than predicted, and likewise for being lower. The residual correlation remains freely estimated even though the other parameters are pooled. + +## Interpreting the fitted DIM [← Results](#fitting-the-dim){.appendix-back-link} {.smaller .interpretation-slide} + +::: {.interpretation-footnote} +Red estimates are not statistically distinguishable from zero at +$\alpha = .05$. Their numerical translations are shown only to demonstrate how +DIM coefficients are interpreted; they should not be treated as evidence of a +nonzero effect. +::: + +**Intercepts:** For a couple with an average support mean: + +- $b_0$: Predicted couple-mean MVPA is 31.21 minutes. +- The member-deviation intercept is constrained to zero: a member with no support deviation has no predicted MVPA deviation from the couple mean. + +Holding the **members' support deviations fixed**, a one-unit higher couple-mean support score is associated with: + +- $b_{\mathrm{mean}}$: 9.72 additional minutes of couple-mean MVPA. + +Holding couple-mean support at the **sample average**, a one-unit larger member support deviation from the couple mean is associated with: + +- [$b_{\mathrm{dev}}$: A 5.78-minute larger member MVPA deviation from the couple mean. Thus, a member whose support is one unit above the couple mean is predicted to have MVPA 5.78 minutes above the couple mean.]{.not-significant} + +**Residual correlation:** Exchangeability constrains the correlation between the residual couple mean and residual member deviation to zero. Thus, couples whose MVPA is higher than predicted on average are not expected to tilt systematically toward either arbitrarily labeled member in residual MVPA. This is a model constraint, not an empirical finding, and it does not imply that the two partners' residuals are independent. + +## Interpreting the fitted DSM [← Results](#fitted-dsm-results){.appendix-back-link} {.smaller .interpretation-slide} + +::: {.interpretation-footnote} +Red estimates are not statistically distinguishable from zero at +$\alpha = .05$. Their numerical translations are shown only to demonstrate how +DSM coefficients are interpreted; they should not be treated as evidence of a +nonzero effect. +::: + +**Intercepts:** For a couple with an average support mean and no female–male support difference: + +- $a_{10}$: Predicted couple-mean MVPA is 33.26 minutes. +- [$a_{20}$: The female is predicted to be 4.04 minutes more active than the male.]{.not-significant} + +Holding the **female–male support difference at zero**, a one-unit higher couple-mean support score is associated with: + +- $a_{11}$: 9.25 additional minutes of couple-mean MVPA. +- [$a_{21}$: A 2.40-minute larger female–male MVPA difference. Thus, when couple-mean support is one unit above the sample average, the predicted difference is $4.04 + 2.40 = 6.44$ minutes.]{.not-significant} + +Holding couple-mean support at the **sample average**, a one-unit larger female–male support difference is associated with: + +- $a_{12}$: 11.86 fewer minutes of couple-mean MVPA. +- [$a_{22}$: A 4.06-minute larger female–male MVPA difference. Thus, when the female–male support difference is one unit, the predicted difference is $4.04 + 4.06 = 8.10$ minutes.]{.not-significant} + +**Residual correlation ($\rho = .37$):** Couples with higher-than-predicted mean MVPA also tend to show a more positive-than-predicted female–male MVPA difference; residual MVPA therefore tilts toward the female. + +## Exchangeable CFM: constraints and degrees of freedom {.smaller} + +Positions 1 and 2 are arbitrary. The model must be unchanged when they are +swapped [@ledermannMediationDyadicData2009; @peughAnalyzingMixedDyadic2013]. + +$$ +\begin{aligned} +\nu_{X_1} &= \nu_{X_2}, & \nu_{Y_1} &= \nu_{Y_2} \\ +\sigma^2_{\epsilon_{X_1}} &= \sigma^2_{\epsilon_{X_2}}, & +\sigma^2_{\epsilon_{Y_1}} &= \sigma^2_{\epsilon_{Y_2}} \\ +\operatorname{Cov}(\epsilon_{X_1},\epsilon_{Y_1}) +&= \operatorname{Cov}(\epsilon_{X_2},\epsilon_{Y_2}) +\end{aligned} +$$ + +- All four loadings remain fixed to 1. +- Ordinary wide-data **df = 6**; **df = 0** against the exchangeable saturated + model. +- Usual exchangeability test: $\Delta df = 5$; here: $\Delta df = 4$ + ($\sigma^2_{\epsilon_Y}$ is already equal). + +:::{.notes} + +- Equality is imposed on the two same-member residual covariances. Because the + corresponding residual variances are also equal, the residual correlations + are equal as a consequence. +- `lavaan` reports 6 degrees of freedom because its default saturated reference + model is fully unrestricted. Six observed-moment restrictions are required + for exchangeability. +- The exchangeable CFM reproduces the exchangeable saturated model, so it has + zero degrees of freedom relative to that appropriate reference model. Its + ordinary chi-square is therefore a test of exchangeability, not an additional + test of the basic CFM structure. +- An unconstrained distinguishable CFM has df = 1, giving the usual five-degree- + of-freedom exchangeability test. Our distinguishable model already equates the + two outcome residual variances and has df = 2, so the comparison tests the four + remaining equality constraints. + +::: + ## Distinguishable APIM: residual covariance ### Within-dyad residual covariance block (shared across dyads): diff --git a/dev/workshop/dyadic-data.rds b/dev/workshop/dyadic-data.rds new file mode 100644 index 00000000..af304410 Binary files /dev/null and b/dev/workshop/dyadic-data.rds differ diff --git a/dev/workshop/dyadic-ild-exercise.rds b/dev/workshop/dyadic-ild-exercise.rds new file mode 100644 index 00000000..36e89fe4 Binary files /dev/null and b/dev/workshop/dyadic-ild-exercise.rds differ diff --git a/dev/workshop/dyadic-person-means.rds b/dev/workshop/dyadic-person-means.rds new file mode 100644 index 00000000..084168d3 Binary files /dev/null and b/dev/workshop/dyadic-person-means.rds differ diff --git a/dev/workshop/helpers.R b/dev/workshop/helpers.R new file mode 100644 index 00000000..199456d0 --- /dev/null +++ b/dev/workshop/helpers.R @@ -0,0 +1,435 @@ +plot_mahalanobis <- function(data, x, y, dyad = "couple_id", + n_labels = 4, title = NULL) { + required_columns <- c(x, y, dyad) + missing_columns <- setdiff(required_columns, names(data)) + + if (length(missing_columns) > 0) { + stop( + "Missing columns: ", paste(missing_columns, collapse = ", "), + call. = FALSE + ) + } + + plot_data <- data[stats::complete.cases(data[required_columns]), , drop = FALSE] + xy <- plot_data[c(x, y)] + + if (!all(vapply(xy, is.numeric, logical(1)))) { + stop("Both x and y must be numeric.", call. = FALSE) + } + + if (nrow(plot_data) < 3 || qr(stats::cov(xy))$rank < 2) { + stop( + "Mahalanobis distance requires at least three complete, non-collinear observations.", + call. = FALSE + ) + } + + plot_data$.mahalanobis_distance <- stats::mahalanobis( + xy, + center = colMeans(xy), + cov = stats::cov(xy) + ) + + label_order <- order( + plot_data$.mahalanobis_distance, + decreasing = TRUE + ) + label_order <- head(label_order, n_labels) + label_data <- plot_data[label_order, , drop = FALSE] + + ggplot2::ggplot( + plot_data, + ggplot2::aes(x = .data[[x]], y = .data[[y]]) + ) + + ggplot2::geom_point(color = "steelblue") + + ggplot2::geom_smooth( + method = "lm", + formula = y ~ x, + se = FALSE, + color = "navy", + linewidth = 1.1 + ) + + ggplot2::geom_text( + data = label_data, + ggplot2::aes(label = .data[[dyad]]), + vjust = -0.6, + check_overlap = TRUE + ) + + ggplot2::labs( + title = title, + x = x, + y = y, + caption = paste( + "Labels mark the", + min(n_labels, nrow(plot_data)), + "largest Mahalanobis distances." + ) + ) + + ggplot2::scale_y_continuous( + expand = ggplot2::expansion(mult = c(0.05, 0.12)) + ) + + ggplot2::theme_minimal(base_size = 13) + + ggplot2::theme( + plot.title.position = "panel", + plot.title = ggplot2::element_text(hjust = 0.5) + ) +} + +make_ild_ar1_start <- function( + data, + stable_sd = c(female = 0.50, male = 0.50), + stable_rho = 0.20, + ar_sd = c(female = 0.50, male = 0.50), + ar_rho = c(female = 0.50, male = 0.50), + same_day_sd = c(female = 0.50, male = 0.50), + same_day_rho = 0.20) { + required_columns <- c( + "closeness", + ".is_female", + ".is_male", + "diaryday_c", + ".provided_support_cwp_actor", + ".provided_support_cwp_partner", + ".provided_support_cbp_actor", + ".provided_support_cbp_partner" + ) + missing_columns <- setdiff(required_columns, names(data)) + if (length(missing_columns) > 0L) { + stop( + "Missing columns: ", + paste(missing_columns, collapse = ", "), + call. = FALSE + ) + } + if (length(stable_sd) != 2L || + any(!is.finite(stable_sd)) || + any(stable_sd <= 0)) { + stop("stable_sd must contain two positive finite values.", call. = FALSE) + } + if (length(ar_sd) != 2L || any(!is.finite(ar_sd)) || any(ar_sd <= 0)) { + stop("ar_sd must contain two positive finite values.", call. = FALSE) + } + if (length(same_day_sd) != 2L || + any(!is.finite(same_day_sd)) || + any(same_day_sd <= 0)) { + stop("same_day_sd must contain two positive finite values.", call. = FALSE) + } + if (length(ar_rho) != 2L || + any(!is.finite(ar_rho)) || + any(abs(ar_rho) >= 1)) { + stop("ar_rho must contain two finite values between -1 and 1.", call. = FALSE) + } + if (length(stable_rho) != 1L || + !is.finite(stable_rho) || + abs(stable_rho) >= 1) { + stop( + "stable_rho must be one finite value between -1 and 1.", + call. = FALSE + ) + } + if (length(same_day_rho) != 1L || + !is.finite(same_day_rho) || + abs(same_day_rho) >= 1) { + stop( + "same_day_rho must be one finite value between -1 and 1.", + call. = FALSE + ) + } + + fixed_formula <- closeness ~ + 0 + .is_female + .is_male + + .is_female:diaryday_c + + .is_male:diaryday_c + + .is_female:.provided_support_cwp_actor + + .is_male:.provided_support_cwp_actor + + .is_female:.provided_support_cwp_partner + + .is_male:.provided_support_cwp_partner + + .is_female:.provided_support_cbp_actor + + .is_male:.provided_support_cbp_actor + + .is_female:.provided_support_cbp_partner + + .is_male:.provided_support_cbp_partner + + fixed_model <- stats::lm(fixed_formula, data = data) + beta_start <- stats::coef(fixed_model) + if (length(beta_start) != 12L || any(!is.finite(beta_start))) { + stop( + "The fixed-effects starting model must have 12 finite coefficients.", + call. = FALSE + ) + } + + list( + beta = unname(beta_start), + theta = unname(c( + log(stable_sd[[1L]]), + log(stable_sd[[2L]]), + glmmTMB::put_cor(stable_rho, input_val = "vec"), + log(ar_sd[[1L]]), + glmmTMB::put_cor(ar_rho[[1L]], input_val = "vec"), + log(ar_sd[[2L]]), + glmmTMB::put_cor(ar_rho[[2L]], input_val = "vec"), + log(same_day_sd[[1L]]), + log(same_day_sd[[2L]]), + glmmTMB::put_cor(same_day_rho, input_val = "vec") + )) + ) +} + +make_pooled_apim_effects_start <- function(role_specific_model) { + if (!inherits(role_specific_model, "glmmTMB")) { + stop("role_specific_model must be a fitted glmmTMB model.", call. = FALSE) + } + if (role_specific_model$fit$convergence != 0L || + !isTRUE(role_specific_model$sdr$pdHess)) { + stop( + "The role-specific model must converge with a positive-definite Hessian.", + call. = FALSE + ) + } + + role_specific_beta <- glmmTMB::fixef(role_specific_model)$cond + intercept_names <- c( + ".is_female", + ".is_male" + ) + time_names <- c( + ".is_female:diaryday_c", + ".is_male:diaryday_c" + ) + effect_pairs <- list( + c( + ".is_female:.provided_support_cwp_actor", + ".is_male:.provided_support_cwp_actor" + ), + c( + ".is_female:.provided_support_cwp_partner", + ".is_male:.provided_support_cwp_partner" + ), + c( + ".is_female:.provided_support_cbp_actor", + ".is_male:.provided_support_cbp_actor" + ), + c( + ".is_female:.provided_support_cbp_partner", + ".is_male:.provided_support_cbp_partner" + ) + ) + required_names <- c(intercept_names, time_names, unlist(effect_pairs)) + missing_names <- setdiff(required_names, names(role_specific_beta)) + if (length(missing_names) > 0L) { + stop( + "Missing fixed effects: ", + paste(missing_names, collapse = ", "), + call. = FALSE + ) + } + + pooled_effects <- numeric(length(effect_pairs)) + for (effect_index in seq_along(effect_pairs)) { + pooled_effects[[effect_index]] <- mean( + role_specific_beta[effect_pairs[[effect_index]]] + ) + } + + list( + beta = unname(c( + role_specific_beta[intercept_names], + pooled_effects, + role_specific_beta[time_names] + )), + theta = unname(glmmTMB::getME(role_specific_model, "theta")) + ) +} + +simulate_ild_dharma <- function(model, dyad, member, time, role = NULL, + n = 250, seed = 123) { + model_family <- stats::family(model) + if (model_family$family != "gaussian" || + model_family$link != "identity") { + stop( + "Block whitening is implemented only for Gaussian identity-link models.", + call. = FALSE + ) + } + + model_data <- stats::model.frame(model) + model_rows <- suppressWarnings(as.integer(rownames(model_data))) + align_rows <- function(x) { + if (length(x) == nrow(model_data)) { + return(x) + } + if (anyNA(model_rows) || max(model_rows) > length(x)) { + stop("Could not align identifiers with the fitted model.", call. = FALSE) + } + x[model_rows] + } + + dyad_id <- align_rows(dyad) + member_id <- align_rows(member) + time_id <- align_rows(time) + role_id <- if (is.null(role)) NULL else align_rows(role) + if (anyNA(dyad_id) || anyNA(member_id) || anyNA(time_id)) { + stop("Dyad, member, and time identifiers must be complete.", call. = FALSE) + } + if (!is.null(role_id) && anyNA(role_id)) { + stop("Role identifiers must be complete.", call. = FALSE) + } + if (!is.numeric(time_id)) { + stop("Time must be numeric.", call. = FALSE) + } + blocks <- split(seq_along(dyad_id), dyad_id) + if (n <= max(lengths(blocks))) { + stop("n must exceed the largest couple block.", call. = FALSE) + } + + dharma_residuals <- DHARMa::simulateResiduals( + fittedModel = model, + n = 2 * n, + simulateREs = "unconditional", + refit = FALSE, + seed = seed, + plot = FALSE + ) + + simulations <- as.matrix(dharma_residuals$simulatedResponse) + covariance_simulations <- simulations[, seq_len(n), drop = FALSE] + evaluation_simulations <- simulations[, n + seq_len(n), drop = FALSE] + expected <- as.numeric(stats::predict( + model, + re.form = NA, + type = "response" + )) + + covariance_simulations <- sweep(covariance_simulations, 1, expected) + whitened_simulations <- sweep(evaluation_simulations, 1, expected) + whitened_observed <- dharma_residuals$observedResponse - expected + + for (rows in blocks) { + rows <- rows[order(time_id[rows], member_id[rows])] + response_covariance <- stats::cov( + t(covariance_simulations[rows, , drop = FALSE]) + ) + ridge <- max(mean(diag(response_covariance)), 1) * + sqrt(.Machine$double.eps) + lower_cholesky <- t(chol( + response_covariance + diag(ridge, length(rows)) + )) + whitened_observed[rows] <- forwardsolve( + lower_cholesky, + whitened_observed[rows] + ) + whitened_simulations[rows, ] <- forwardsolve( + lower_cholesky, + whitened_simulations[rows, , drop = FALSE] + ) + } + + dharma_residuals$simulatedResponse <- evaluation_simulations + dharma_residuals$nSim <- n + dharma_residuals$fittedPredictedResponse <- expected + dharma_residuals$scaledResiduals <- DHARMa::getQuantile( + simulations = whitened_simulations, + observed = whitened_observed, + integerResponse = FALSE, + method = "PIT" + ) + attr(dharma_residuals, "ild_index") <- list( + person = interaction(dyad_id, member_id, drop = TRUE), + time = time_id, + role = role_id + ) + + dharma_residuals +} + +test_ild_lag1 <- function(residuals, plot = FALSE, by_role = FALSE) { + index <- attr(residuals, "ild_index") + if (is.null(index)) { + stop("Use residuals created by simulate_ild_dharma().", call. = FALSE) + } + + person <- index$person + time <- index$time + role <- index$role + if (by_role && is.null(role)) { + stop( + "Supply role to simulate_ild_dharma() before requesting role-specific tests.", + call. = FALSE + ) + } + ordering <- order(person, time) + previous <- ordering[-length(ordering)] + current <- ordering[-1] + consecutive <- person[current] == person[previous] & + time[current] == time[previous] + 1 + previous <- previous[consecutive] + current <- current[consecutive] + + test_pairs <- function(previous_rows, current_rows, label) { + if (length(current_rows) < 3L) { + stop("At least three consecutive-day pairs are required.", call. = FALSE) + } + + lag1_correlation <- function(response) { + model_residual <- response - residuals$fittedPredictedResponse + model_residual <- model_residual - + ave(model_residual, person, FUN = mean) + stats::cor( + model_residual[previous_rows], + model_residual[current_rows] + ) + } + + if (isTRUE(plot)) { + lag1_label_parameters <- graphics::par(col.lab = "transparent") + on.exit(graphics::par(lag1_label_parameters), add = TRUE) + } + + test <- DHARMa::testGeneric( + residuals, + summary = lag1_correlation, + alternative = "two.sided", + plot = plot, + methodName = paste0( + "Consecutive-day lag-1 residual-dependence check", + label + ) + ) + if (isTRUE(plot)) { + graphics::par(lag1_label_parameters) + p_text <- if (test$p.value < .001) { + "p < .001" + } else { + paste0("p = ", sub("^0", "", sprintf("%.3f", test$p.value))) + } + graphics::title( + xlab = paste("Simulated values; red = observed;", p_text), + ylab = "Frequency" + ) + } + test$statistic <- c( + `lag-1 correlation` = lag1_correlation(residuals$observedResponse) + ) + test + } + + if (!by_role) { + return(test_pairs(previous, current, "")) + } + + role_values <- unique(as.character(role[current])) + role_tests <- vector("list", length(role_values)) + names(role_tests) <- role_values + + for (role_index in seq_along(role_values)) { + role_value <- role_values[[role_index]] + role_pairs <- as.character(role[current]) == role_value + role_tests[[role_index]] <- test_pairs( + previous[role_pairs], + current[role_pairs], + paste0(" for ", role_value) + ) + } + + role_tests +} diff --git a/dev/workshop/hints.R b/dev/workshop/hints.R new file mode 100644 index 00000000..cdc8c1dd --- /dev/null +++ b/dev/workshop/hints.R @@ -0,0 +1,512 @@ +.workshop_hints <- list( + example_hint = list( + run_chunk_without_comment = paste( + "You have revealed your first hint.", + "You can use the other optional hints in the same way." + ) + ), + prepare_data = list( + structure = paste( + "Use prepare_dyad_data() with:", + "- dyad = couple_id", + "- member = person_id", + "- role = gender", + "- predictors = YOUR_PREDICTOR", + "- model_types = \"apim\"", + "- include_arbitrary_member_contrast = TRUE", + "- add_apim_gmc_predictors = TRUE", + sep = "\n" + ) + ), + descriptive_summary = list( + functions = paste( + "Use tidyr::pivot_wider() to create one row per couple, then", + "report::report_table() to summarize the role-specific columns." + ), + example_code = paste( + "my_wide_data <- my_data |>", + " dplyr::select(couple_id, gender, YOUR_PREDICTOR, YOUR_OUTCOME) |>", + " tidyr::pivot_wider(", + " names_from = gender,", + " values_from = c(YOUR_PREDICTOR, YOUR_OUTCOME)", + " )", + "", + "my_wide_data |>", + " dplyr::select(-couple_id) |>", + " report::report_table() |>", + " summary()", + sep = "\n" + ) + ), + histograms = list( + example_code = paste( + "hist(my_data$YOUR_VARIABLE)", + "", + "hist(", + " my_data[my_data$gender == \"male\", ]$YOUR_VARIABLE", + ")", + sep = "\n" + ) + ), + partner_similarity = list( + correlations = paste( + "Use correlation::correlation() on my_wide_data. For example:", + "", + "correlation::correlation(", + " my_wide_data,", + " select = c(\"YOUR_PREDICTOR_female\", \"YOUR_OUTCOME_female\"),", + " select2 = c(\"YOUR_PREDICTOR_male\", \"YOUR_OUTCOME_male\")", + ")", + sep = "\n" + ), + plot = paste( + "For one focal variable:", + "", + "plot(", + " my_wide_data$YOUR_VARIABLE_female,", + " my_wide_data$YOUR_VARIABLE_male,", + " xlab = \"Women\", ylab = \"Men\"", + ")", + "abline(", + " lm(YOUR_VARIABLE_male ~ YOUR_VARIABLE_female, data = my_wide_data),", + " col = \"navy\", lwd = 2", + ")", + sep = "\n" + ) + ), + distinguishable_model = list( + concept = paste( + "A distinguishable APIM needs role-specific intercepts, actor effects,", + "partner effects, and a covariance between the two members' residuals." + ), + structure = paste( + "Check that your glmmTMB model contains:", + "- 0 + both role indicators", + "- each role indicator interacted with the actor predictor", + "- each role indicator interacted with the partner predictor", + "- an unstructured role-specific random-effects block within couple", + "- dispformula = ~ 0", + sep = "\n" + ), + example_code = paste( + "Example using the tutorial variables:", + "", + "my_model <- glmmTMB(", + " total_mvpa ~", + " 0 + .is_female + .is_male +", + " .is_female:.efficacy_gmc_actor +", + " .is_male:.efficacy_gmc_actor +", + " .is_female:.efficacy_gmc_partner +", + " .is_male:.efficacy_gmc_partner +", + " (0 + .is_female + .is_male | couple_id),", + " dispformula = ~ 0,", + " family = gaussian(),", + " data = my_data", + ")", + sep = "\n" + ) + ), + robustness_mahalanobis = list( + columns = paste( + "Example only: suppose retained_model uses the stored outcome", + "sqrt_total_mvpa and the generated efficacy predictors.", + "", + "women_actor_plot <- plot_mahalanobis(", + " data = dplyr::filter(my_data, gender == \"female\"),", + " x = \".efficacy_gmc_actor\",", + " y = \"sqrt_total_mvpa\",", + " title = \"Women\"", + ")", + "", + "For the partner plot, change x to \".efficacy_gmc_partner\". Apply the", + "same change to the men's plot, and replace all example names with the", + "columns from your own model.", + sep = "\n" + ) + ), + robustness_refit = list( + ids = paste( + "Store the IDs in a vector. For example:", + "DYAD_IDS_TO_EXCLUDE <- c(2, 35)" + ) + ), + exchangeable_model = list( + fixed_effects = paste( + "Replace the role-specific fixed effects with one pooled intercept,", + "one actor effect, and one partner effect." + ), + random_effects = paste( + "Represent the exchangeable residual covariance with a shared block", + "(1 | couple_id) and a difference block", + "(0 + .member_contrast_arbitrary | couple_id)." + ), + example_code = paste( + "my_exchangeable_model <- glmmTMB(", + " YOUR_OUTCOME ~", + " 1 +", + " YOUR_ACTOR_PREDICTOR +", + " YOUR_PARTNER_PREDICTOR +", + " (1 | couple_id) +", + " (0 + .member_contrast_arbitrary | couple_id),", + " dispformula = ~ 0,", + " family = gaussian(),", + " data = my_data", + ")", + sep = "\n" + ) + ), + report_results = list( + fixed_effects = paste( + "parameters::model_parameters(retained_model, effects = \"fixed\")" + ), + random_effects = paste( + "parameters::model_parameters(retained_model, effects = \"random\")", + "", + "For an exchangeable model, also use:", + "dyadMLM::recover_exchangeable_covariance(retained_model)", + sep = "\n" + ), + plot = paste( + "parameters::model_parameters(retained_model, effects = \"fixed\") |>", + " plot(show_intercept = TRUE)", + sep = "\n" + ) + ), + dim_transformation = list( + formulas = paste( + "The between-dyad effect is the sum of the actor and partner effects:", + "b_mean <- b_actor + b_partner", + "", + "The within-dyad effect is their difference:", + "b_dev <- b_actor - b_partner", + sep = "\n" + ) + ), + outcome_scale = list( + matched_models = paste( + "The distinguishable and exchangeable models must use the same stored", + "outcome column and the same analysis rows.", + "", + "If you transform the outcome, first add one new column to my_data.", + "Then refit and diagnose both candidate models with that column as the", + "outcome before comparing them.", + "", + "Do not compare a raw-outcome model with a transformed-outcome model.", + "compare_nested_models() will reject models fitted on different outcome", + "columns or values.", + "", + "The helper checks compatibility and estimation quality, but it cannot", + "prove mathematical nesting. The formulas must differ only by the", + "constraints you intend to test.", + sep = "\n" + ) + ), + ild_preparation = list( + solution = paste( + "my_ild_data <- dyadMLM::prepare_dyad_data(", + " data = raw_ild_data,", + " dyad = coupleID,", + " member = personID,", + " role = gender,", + " time = diaryday,", + " predictors = provided_support,", + " model_types = \"apim\",", + " temporal_decomposition = \"2l\"", + ")", + sep = "\n" + ), + time_variables = paste( + "my_ild_data <- my_ild_data |>", + " dplyr::mutate(", + " diaryday_c = (diaryday - 6.5) / 13,", + " diaryday_f = factor(diaryday, levels = 0:13)", + " )", + sep = "\n" + ) + ), + ild_descriptives = list( + summary = paste( + "summary(", + " my_ild_data[c(\"provided_support\", \"closeness\")]", + ")", + "", + "my_ild_data |>", + " dplyr::group_by(gender) |>", + " dplyr::summarise(", + " n = dplyr::n(),", + " support_mean = mean(provided_support, na.rm = TRUE),", + " support_sd = stats::sd(provided_support, na.rm = TRUE),", + " closeness_mean = mean(closeness, na.rm = TRUE),", + " closeness_sd = stats::sd(closeness, na.rm = TRUE),", + " .groups = \"drop\"", + " )", + sep = "\n" + ), + histograms = paste( + "old_par <- graphics::par(mfrow = c(2, 2))", + "", + "graphics::hist(", + " my_ild_data$provided_support[my_ild_data$gender == \"female\"],", + " main = \"Provided support: women\",", + " xlab = \"Provided support\"", + ")", + "graphics::hist(", + " my_ild_data$provided_support[my_ild_data$gender == \"male\"],", + " main = \"Provided support: men\",", + " xlab = \"Provided support\"", + ")", + "graphics::hist(", + " my_ild_data$closeness[my_ild_data$gender == \"female\"],", + " main = \"Closeness: women\",", + " xlab = \"Closeness\"", + ")", + "graphics::hist(", + " my_ild_data$closeness[my_ild_data$gender == \"male\"],", + " main = \"Closeness: men\",", + " xlab = \"Closeness\"", + ")", + "", + "graphics::par(old_par)", + sep = "\n" + ) + ), + ild_trajectories = list( + structure = paste( + "The measure and score columns now identify what is measured and its value.", + "Each line needs one group per person within couple. Put measures in facet", + "rows and couples in facet columns.", + sep = "\n" + ), + solution = paste( + "ggplot2::ggplot(", + " trajectory_data,", + " ggplot2::aes(", + " x = diaryday,", + " y = score,", + " color = gender,", + " group = interaction(coupleID, personID)", + " )", + ") +", + " ggplot2::geom_line(na.rm = TRUE) +", + " ggplot2::geom_point(na.rm = TRUE) +", + " ggplot2::facet_grid(measure ~ coupleID, scales = \"free_y\") +", + " ggplot2::labs(x = \"Diary day\", y = NULL, color = \"Gender\") +", + " ggplot2::theme_minimal()", + sep = "\n" + ) + ), + ild_level_associations = list( + structure = paste( + "In the within-couple matrix:", + "- female actor: provided_support_female with closeness_female", + "- female partner: provided_support_male with closeness_female", + "- male actor: provided_support_male with closeness_male", + "- male partner: provided_support_female with closeness_male", + "", + "The same pairs in the between-couple matrix describe associations among", + "the corresponding role-specific person means.", + sep = "\n" + ), + solution = paste( + "ild_wide_data <- my_ild_data |>", + " dplyr::select(", + " coupleID, diaryday, gender, provided_support, closeness", + " ) |>", + " tidyr::pivot_wider(", + " names_from = gender,", + " values_from = c(provided_support, closeness)", + " )", + "", + "ild_level_correlations <- wbCorr::wbCorr(", + " data = dplyr::select(ild_wide_data, -diaryday),", + " cluster = \"coupleID\",", + " inference = \"none\"", + ")", + "", + "wbCorr::get_matrix(ild_level_correlations)", + "wbCorr::get_ICC(ild_level_correlations)", + sep = "\n" + ) + ), + ild_models = list( + distinguishable_ar1 = paste( + "ild_ar1_start <- make_ild_ar1_start(my_ild_data)", + "", + "distinguishable_ar1_model <- glmmTMB::glmmTMB(", + " closeness ~", + " 0 + .is_female + .is_male +", + " .is_female:diaryday_c +", + " .is_male:diaryday_c +", + " .is_female:.provided_support_cwp_actor +", + " .is_male:.provided_support_cwp_actor +", + " .is_female:.provided_support_cwp_partner +", + " .is_male:.provided_support_cwp_partner +", + " .is_female:.provided_support_cbp_actor +", + " .is_male:.provided_support_cbp_actor +", + " .is_female:.provided_support_cbp_partner +", + " .is_male:.provided_support_cbp_partner +", + " (0 + .is_female + .is_male | coupleID) +", + " ar1(0 + .is_female:diaryday_f | coupleID) +", + " ar1(0 + .is_male:diaryday_f | coupleID) +", + " (0 + .is_female + .is_male | coupleID:diaryday),", + " dispformula = ~ 0,", + " family = gaussian(),", + " data = my_ild_data,", + " control = ild_control,", + " start = ild_ar1_start", + ")", + sep = "\n" + ), + pooled_apim_effects = paste( + "pooled_apim_effects_start <- make_pooled_apim_effects_start(", + " distinguishable_model", + ")", + "", + "pooled_apim_effects_model <- update(", + " distinguishable_model,", + " formula = . ~ . -", + " .is_female:.provided_support_cwp_actor -", + " .is_male:.provided_support_cwp_actor -", + " .is_female:.provided_support_cwp_partner -", + " .is_male:.provided_support_cwp_partner -", + " .is_female:.provided_support_cbp_actor -", + " .is_male:.provided_support_cbp_actor -", + " .is_female:.provided_support_cbp_partner -", + " .is_male:.provided_support_cbp_partner +", + " .provided_support_cwp_actor +", + " .provided_support_cwp_partner +", + " .provided_support_cbp_actor +", + " .provided_support_cbp_partner,", + " start = pooled_apim_effects_start", + ")", + sep = "\n" + ) + ), + ild_reporting = list( + solution = paste( + "ild_fixed_effects <- parameters::model_parameters(", + " retained_model,", + " effects = \"fixed\",", + " ci = 0.95", + ")", + "", + "ild_random_effects <- parameters::model_parameters(", + " retained_model,", + " effects = \"random\",", + " ci = 0.95", + ")", + "", + "ild_fixed_effects", + "ild_random_effects", + "glmmTMB::VarCorr(retained_model)", + sep = "\n" + ), + plot = paste( + "plot(", + " ild_fixed_effects,", + " show_intercept = TRUE", + ")", + sep = "\n" + ), + paragraph_template = paste( + "Use this structure and replace every bracketed item with your result:", + "", + "\"We analyzed [number] female-male dyads measured on up to [number]", + "days. Role-specific AR(1) residual processes were fitted and [diagnostic", + "result]. [Role-specific / pooled] APIM associations were retained because", + "[four-df comparison and substantive reason]. Within-person actor and", + "partner associations were [estimates and 95% CIs]; between-person actor", + "and partner associations were [estimates and 95% CIs]. Stable dyad,", + "same-occasion partner, and AR(1) covariance estimates were [summary].", + "Residual and robustness checks [brief conclusion].\"", + sep = "\n" + ) + ), + ild_diagnostics = list( + solution = paste( + "Checkpoint: With the supplied dataset and diagnostic seed, the observed", + "female and male lag-1 statistics are both compatible with simulations", + "from the fitted role-specific AR(1) model. Retain the AR(1)", + "specification unless your other residual plots reveal a clear problem.", + "", + "Remember that a nonzero raw residual correlation is not itself a failure:", + "the calibrated check asks whether it is unusual under the fitted model.", + sep = "\n" + ) + ), + ild_ar1 = list( + role_specific_syntax = paste( + "Add these two terms:", + "", + "ar1(0 + .is_female:diaryday_f | coupleID) +", + "ar1(0 + .is_male:diaryday_f | coupleID)", + "", + "The levels of diaryday_f must follow the scheduled day order. Keep", + "the separate coupleID:diaryday covariance block in the model.", + sep = "\n" + ) + ), + ild_model_choices = list( + role_solution = paste( + "Checkpoint: For the supplied dataset, the four-df likelihood-ratio test", + "is chi-squared = 89.70, p < .001. Retain the role-specific focal", + "associations. This is not a test of full exchangeability because the", + "baseline, covariance, and AR(1) parameters remain role-specific.", + "", + "retained_model <- distinguishable_model", + sep = "\n" + ) + ), + ild_optimizer = list( + bfgs = paste( + "The exercise uses this tested control for every candidate model:", + "", + "ild_control <- glmmTMB::glmmTMBControl(", + " profile = TRUE,", + " optimizer = stats::optim,", + " optArgs = list(method = \"BFGS\"),", + " optCtrl = list(maxit = 2000, reltol = 1e-10)", + ")", + "", + "Add control = ild_control to each direct glmmTMB() call. update() then", + "inherits it. Still check convergence, the Hessian, and boundaries; the", + "optimizer does not rescue a statistically inadequate specification.", + sep = "\n" + ) + ) +) + +hint_topics <- function() { + topics <- names(.workshop_hints) + + cat("Available hint topics:\n") + cat(paste0(" - ", topics), sep = "\n") + cat("\n") + + invisible(topics) +} + +hint <- function(topic, level = "concept") { + if (!topic %in% names(.workshop_hints)) { + stop( + "Unknown hint topic. Run hint_topics() to see the available topics.", + call. = FALSE + ) + } + + topic_hints <- .workshop_hints[[topic]] + + if (!level %in% names(topic_hints)) { + stop( + "Available levels for '", topic, "': ", + paste(names(topic_hints), collapse = ", "), + call. = FALSE + ) + } + + hint_text <- topic_hints[[level]] + + cat("\n", hint_text, "\n\n", sep = "") + + invisible(hint_text) +} diff --git a/dev/workshop/workshop.css b/dev/workshop/workshop.css index e73222d9..838de5fa 100644 --- a/dev/workshop/workshop.css +++ b/dev/workshop/workshop.css @@ -18,6 +18,44 @@ --interdep-residual-correlation: #546e7a; } +/* Interpretation cautions ----------------------------------------------- */ +.reveal .not-significant, +.reveal .interpretation-footnote { + color: #b42318; +} + +.reveal .interpretation-footnote { + font-size: 0.66em; + line-height: 1.2; + margin-top: 0.45em; +} + +.reveal .interpretation-footnote p { + margin: 0; +} + +.reveal .slides section.interpretation-slide p { + margin: 0.38em 0; +} + +.reveal .slides section.interpretation-slide ul { + margin-top: 0.18em; + margin-bottom: 0.42em; +} + +.reveal .slides section.interpretation-slide li { + margin-top: 0.1em; + margin-bottom: 0.1em; +} + +.reveal .appendix-back-link, +.reveal .results-forward-link { + float: right; + font-size: 0.36em; + font-weight: 500; + margin-top: 0.85em; +} + /* Transition between the two workshop decks ------------------------------ */ .reveal .workshop-next { display: grid; @@ -307,36 +345,125 @@ } .reveal table { + width: auto; + max-width: 100%; + margin: 0.35em auto 0; + border-collapse: collapse; + border-spacing: 0; + border: 0; + border-top: 1px solid var(--uzh-rule); + border-bottom: 1px solid var(--uzh-rule); + background: transparent; + font-size: 0.65em; +} + +.reveal table th { + padding: 0.3em 0.5em; + border: 0; + border-bottom: 1.5px solid var(--uzh-muted); + background: transparent; + color: var(--uzh-ink); + font-weight: 600; +} + +.reveal table td { + padding: 0.26em 0.5em; + border: 0; + border-bottom: 1px solid var(--uzh-rule); +} + +.reveal table tr:nth-child(even) td { + background: transparent; +} + +.reveal table tr:last-child td { + border-bottom: 0; +} + +/* Let the compact leave-one-dyad-out summary use the available slide space. */ +.reveal .loo-summary-table table { + margin-top: 1em; + font-size: 0.8em; +} + +/* Reserve the branded treatment for presentation-oriented overview tables. */ +.reveal .fancy-table table { width: 100%; - margin-top: 0.35em; + max-width: 100%; + table-layout: fixed; border-collapse: separate; - border-spacing: 0; - font-size: 0.78em; - overflow: hidden; border: 1px solid var(--uzh-rule); border-radius: 7px; + font-size: 0.78em; + overflow: hidden; } -.reveal table th { +.reveal .fancy-table table col:first-child { + width: 18% !important; +} + +.reveal .fancy-table table col:last-child { + width: 82% !important; +} + +.reveal .fancy-table table th:first-child, +.reveal .fancy-table table td:first-child { + width: 18%; +} + +.reveal .fancy-table table th { padding: 0.46em 0.65em; - border: 0; + border-bottom: 0; background: var(--uzh-blue); color: white; font-weight: 600; + text-align: left; } -.reveal table td { +.reveal .fancy-table table td { padding: 0.4em 0.65em; - border: 0; border-bottom: 1px solid var(--uzh-rule); + text-align: left; } -.reveal table tr:nth-child(even) td { +.reveal .fancy-table table tr:nth-child(even) td { background: var(--uzh-surface); } -.reveal table tr:last-child td { - border-bottom: 0; +.reveal .agenda-completed { + color: #9aa7bd; +} + +/* Give executed code and its output a little visual separation. */ +.reveal .cell > .cell-code + .cell-output, +.reveal .cell > .cell-code + .cell-output-display, +.reveal .cell > .cell-code + .cell-output-stdout, +.reveal .cell > .code-copy-outer-scaffold + .cell-output, +.reveal .cell > .code-copy-outer-scaffold + .cell-output-display, +.reveal .cell > .code-copy-outer-scaffold + .cell-output-stdout { + margin-top: 0.4em; +} + +/* Let separate console-output slides use the available height before scrolling. */ +.reveal .slides section.output-location-slide.present { + display: grid !important; + grid-template-rows: auto minmax(0, 1fr); + box-sizing: border-box; + padding-bottom: 1.2em; +} + +.reveal .slides section.output-location-slide > .cell.output-location-slide, +.reveal .slides section.output-location-slide .cell-output-stdout, +.reveal .slides section.output-location-slide .cell-output-stdout > pre { + min-width: 0; + min-height: 0; + height: 100%; +} + +.reveal .slides section.output-location-slide .cell-output-stdout > pre > code { + box-sizing: border-box; + max-height: 100%; + overflow: auto; } .reveal blockquote { @@ -353,6 +480,10 @@ color: var(--uzh-blue-dark); } +.reveal .text-smaller { + font-size: 0.82em; +} + .reveal .subtle { font-size: 0.76em; color: var(--uzh-muted); @@ -362,6 +493,19 @@ color: inherit; } +.reveal h2 .heading-reference { + margin-left: 0.45em; + color: var(--uzh-muted); + font-size: 0.42em; + font-weight: 400; + white-space: nowrap; + vertical-align: 0.12em; +} + +.reveal h2 .heading-reference a { + color: inherit; +} + /* Keep source citations stable while preceding fragments are revealed. */ .reveal .bottom-reference { position: absolute; diff --git a/inst/WORDLIST b/inst/WORDLIST index 9060fa87..e57feaee 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -24,14 +24,13 @@ Nickell RDSEM Reparameterization TMB -Tweedie Zenodo al bmatrix -boldsymbol brms cbp cdots +conflictual cwp ddots del @@ -53,6 +52,7 @@ personID pmatrix pre qquad +recentered reparameterization rightarrow tibble diff --git a/man/add_actor_partner_columns.Rd b/man/add_actor_partner_columns.Rd index ed6f8b91..9336ba89 100644 --- a/man/add_actor_partner_columns.Rd +++ b/man/add_actor_partner_columns.Rd @@ -20,8 +20,8 @@ partner versions of the raw predictor. For centered intensive longitudinal predictors, this will create actor and partner versions of the raw predictor and each recorded predictor component, such as the within-person and between-person components created by \code{\link[=center_predictors]{center_predictors()}}. -Selected lag predictors additionally create lag-1 raw and within-person -actor and partner columns. +Selected lag predictors also create actor and partner columns for eligible +lagged components. } \details{ The function will use the predictor decomposition metadata stored in diff --git a/man/add_temporal_lag_columns.Rd b/man/add_temporal_lag_columns.Rd index 2c5d9ee9..b1b50647 100644 --- a/man/add_temporal_lag_columns.Rd +++ b/man/add_temporal_lag_columns.Rd @@ -14,9 +14,8 @@ A \code{dyadMLM_data} object with lagged temporal predictor columns and updated predictor metadata. } \description{ -Adds lag-1 raw and within-person columns for predictors selected through -\code{lag1_predictors}. Values are matched at exactly \code{time - 1}, so construction -does not depend on row order and does not bridge gaps in the measurement -index. Stable between-person components are not lagged. +Adds eligible lag-1 raw, within-person, and APIM GMC source columns. +Values are matched at exactly \code{time - 1}; gaps are not bridged. Stable +between-person components are not lagged. } \keyword{internal} diff --git a/man/center_predictors.Rd b/man/center_predictors.Rd index 20198d5b..bdf139e4 100644 --- a/man/center_predictors.Rd +++ b/man/center_predictors.Rd @@ -4,10 +4,12 @@ \alias{center_predictors} \title{Center predictor variables for dyadic models} \usage{ -center_predictors(data) +center_predictors(data, add_apim_gmc_predictors = FALSE) } \arguments{ \item{data}{A \code{dyadMLM_data} object returned by \code{\link[=prepare_dyad_data]{prepare_dyad_data()}}.} + +\item{add_apim_gmc_predictors}{Whether to add APIM GMC source components.} } \value{ A \code{dyadMLM_data} object with centered predictor columns added and @@ -19,6 +21,7 @@ supports two-level temporal centering for intensive longitudinal predictors: a within-person component and a between-person component. The original predictor remains available as a raw component for model-specific column construction. +It can also add GMC source components for numeric APIM predictors. For two-level temporal centering, the between-person component is centered around the grand mean of person means, not the grand mean of all observed rows. This gives each person equal weight even when people have different numbers of diff --git a/man/compare_nested_glmmTMB_models.Rd b/man/compare_nested_models.Rd similarity index 88% rename from man/compare_nested_glmmTMB_models.Rd rename to man/compare_nested_models.Rd index 107ed2c7..1f5a2b1e 100644 --- a/man/compare_nested_glmmTMB_models.Rd +++ b/man/compare_nested_models.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/compare_dyad_models.R -\name{compare_nested_glmmTMB_models} -\alias{compare_nested_glmmTMB_models} +% Please edit documentation in R/compare_nested_models.R +\name{compare_nested_models} +\alias{compare_nested_models} \title{Compare nested glmmTMB models fitted to equivalent data} \usage{ -compare_nested_glmmTMB_models(model1, model2) +compare_nested_models(model1, model2) } \arguments{ \item{model1, model2}{Two fitted \code{glmmTMB} models to compare.} @@ -26,7 +26,7 @@ shown first in the result. Both model calls must use named data-frame objects that remain available when the models are compared. The checks assume these objects have not been modified since fitting. All ordinary data columns must be identical, -including their types and attributes. For \code{dyadMLM_data}, generated \code{.dy_} +including their types and attributes. For \code{dyadMLM_data}, package-generated columns may differ, but the original columns must be identical. Ordinary and prepared data may be compared with each other. Dyad metadata are checked when both models use \code{dyadMLM_data}. The function also checks fitted rows, @@ -63,7 +63,7 @@ if (requireNamespace("glmmTMB", quietly = TRUE)) { data = full_data ) - compare_nested_glmmTMB_models(restricted_model, full_model) + compare_nested_models(restricted_model, full_model) } } diff --git a/man/dyadMLM-package.Rd b/man/dyadMLM-package.Rd new file mode 100644 index 00000000..1aeb9c8c --- /dev/null +++ b/man/dyadMLM-package.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dyadMLM-package.R +\docType{package} +\name{dyadMLM-package} +\alias{dyadMLM} +\alias{dyadMLM-package} +\title{dyadMLM: Tools for Dyadic Multilevel Models} +\description{ +\code{dyadMLM} validates and prepares cross-sectional and intensive longitudinal +dyadic data for multilevel modeling. It creates model-ready variables for +APIMs, DIMs, and DSMs and provides supporting post-estimation tools. +} +\section{Main functions}{ + +\itemize{ +\item \code{\link[=prepare_dyad_data]{prepare_dyad_data()}} validates long-format dyadic data and creates +model-ready variables. +\item \code{\link[=compare_nested_models]{compare_nested_models()}} compares compatible nested \code{glmmTMB} +models fitted to equivalent data. +\item \code{\link[=recover_exchangeable_covariance]{recover_exchangeable_covariance()}} converts exchangeable +shared/difference covariance structures to member-level quantities. +} +} + +\section{Example data}{ + +See \link{dyads_cross} and \link{dyads_ild} for Gaussian examples, and +\link{dyads_nbinom_cross} and \link{dyads_nbinom_ild} for negative-binomial examples. +} + +\section{Getting started}{ + +See \code{vignette("getting-started", package = "dyadMLM")} for an overview. +The APIM, DIM, and DSM vignettes provide model-specific examples. +} + +\seealso{ +Useful links: +\itemize{ + \item \url{https://pascal-kueng.github.io/dyadMLM/} + \item \url{https://github.com/Pascal-Kueng/dyadMLM} + \item Report bugs at \url{https://github.com/Pascal-Kueng/dyadMLM/issues} +} + +} +\author{ +\strong{Maintainer}: Pascal Küng \email{kueng.pascal@gmail.com} (\href{https://orcid.org/0000-0001-7346-9414}{ORCID}) [copyright holder] + +Authors: +\itemize{ + \item Pascal Küng \email{kueng.pascal@gmail.com} (\href{https://orcid.org/0000-0001-7346-9414}{ORCID}) [copyright holder] +} + +} +\keyword{internal} diff --git a/man/dyad_generated_columns.Rd b/man/dyad_generated_columns.Rd index b02ee58e..d2fcdf55 100644 --- a/man/dyad_generated_columns.Rd +++ b/man/dyad_generated_columns.Rd @@ -10,14 +10,12 @@ dyad_generated_columns(meta) \item{meta}{The \code{dyadMLM} metadata attribute from a \code{dyadMLM_data} object.} } \value{ -A tibble with one row per generated temporal predictor, APIM, DIM, -or DSM column. The \code{lag} column is \code{0} for contemporaneous columns and \code{1} -for lag-1 columns. +A tibble with one row per generated column. The \code{lag} column is \code{0} +for contemporaneous columns and \code{1} for lag-1 columns. } \description{ -Creates a normalized, one-row-per-column view over temporal predictor, APIM, -DIM, and DSM columns stored in a \code{dyadMLM} attribute. This is a -derived lookup table; the model-specific metadata tables remain the source -records. +Returns a normalized, one-row-per-column view of the generated columns +recorded in a \code{dyadMLM} attribute. Shared semantics and display text are +supplied by \code{generated_column_spec_lookup()}. } \keyword{internal} diff --git a/man/dyads_ild.Rd b/man/dyads_ild.Rd index 6f2c665b..b3bf7d7e 100644 --- a/man/dyads_ild.Rd +++ b/man/dyads_ild.Rd @@ -33,6 +33,12 @@ dyads and exchangeable female-female and male-male dyads. Each dyad has two members observed on 14 diary days. } \details{ +The Gaussian outcome includes independent member-specific stationary AR(1) +residual processes. Their marginal standard deviation is 0.60 for both +genders, with correlations of 0.55 for female members and 0.50 for male +members. Separate shared and difference residuals induce same-occasion +partner covariance. + Prepare with \code{dyad = coupleID}, \code{member = personID}, \code{role = gender}, and \code{time = diaryday}. These data contain three compositions. Use \code{keep_compositions} in \code{\link[=prepare_dyad_data]{prepare_dyad_data()}} when an analysis should retain diff --git a/man/infer_dyad_compositions.Rd b/man/infer_dyad_compositions.Rd index d8333cbc..b225c8a1 100644 --- a/man/infer_dyad_compositions.Rd +++ b/man/infer_dyad_compositions.Rd @@ -9,14 +9,16 @@ infer_dyad_compositions( seed = NULL, keep_compositions = NULL, set_exchangeable_compositions = NULL, - pool_compositions = NULL + pool_compositions = NULL, + short_colnames = TRUE, + include_arbitrary_member_contrast = FALSE ) } \arguments{ \item{data}{A \code{dyadMLM_data} object returned by \code{\link[=validate_dyad_data]{validate_dyad_data()}}.} -\item{seed}{Optional seed for random \verb{.dy_member_contrast_*} sign assignment in -exchangeable dyads. If \code{NULL}, the current R session's RNG state is used.} +\item{seed}{Optional seed for random \verb{.member_contrast_*} sign assignment. +If \code{NULL}, the current R session's RNG state is used.} \item{keep_compositions}{Optional observed dyad compositions to keep before exchangeability overrides and pooling.} @@ -27,12 +29,19 @@ exchangeable for analysis.} \item{pool_compositions}{Optional named list that pools exchangeable dyad compositions into user-named final composition labels. Each pool must resolve to at least two distinct observed compositions.} + +\item{short_colnames}{Whether to use shorter composition-dependent generated +column names when the final data contain one composition.} + +\item{include_arbitrary_member_contrast}{Whether to also generate arbitrary +\verb{.member_contrast_*} columns for distinguishable compositions without +changing their composition metadata, roles, or indicators.} } \value{ -A \code{dyadMLM_data} object with added \code{.dy_composition} and -\code{.dy_composition_role} factor columns, \verb{.dy_is_*} numeric indicator columns, -composition-specific numeric \verb{.dy_member_contrast_*} columns coded \code{-1} and -\code{1} for the two members of matching exchangeable dyads and \code{0} otherwise, +A \code{dyadMLM_data} object with added \code{.composition} and +\code{.composition_role} factor columns, \verb{.is_*} numeric indicator columns, +composition-specific numeric \verb{.member_contrast_*} columns coded \code{-1} and +\code{1} for the two members of each matching composition and \code{0} otherwise, and dyad composition metadata. } \description{ diff --git a/man/prepare_dyad_data.Rd b/man/prepare_dyad_data.Rd index 92bae234..a8e3e391 100644 --- a/man/prepare_dyad_data.Rd +++ b/man/prepare_dyad_data.Rd @@ -20,7 +20,10 @@ prepare_dyad_data( pool_compositions = NULL, incomplete_dyads = c("error", "drop"), missing_role = c("error", "drop"), - seed = NULL + seed = NULL, + short_colnames = TRUE, + include_arbitrary_member_contrast = FALSE, + add_apim_gmc_predictors = FALSE ) } \arguments{ @@ -51,8 +54,8 @@ decomposition and model-ready predictor construction.} model-ready columns should be created. Requires \code{time} to be a finite, integer-valued numeric measurement index. Lagging respects the dyad and member structure, matches observations at exactly \code{time - 1}, and does not -bridge missing occasions. Only raw and within-person predictors are -lagged. Stable between-person versions are not.} +bridge missing occasions. Eligible raw, within-person, and APIM GMC +variants are lagged; stable between-person variants are not.} \item{model_types}{Model-ready column families to construct. Can contain one or more of \code{"apim"}, \code{"dim"}, and \code{"dsm"}. \code{"apim"} creates @@ -92,7 +95,11 @@ exchangeable should not be listed. Each composition must be supplied as one string, using \verb{_x_}, \code{-}, \verb{_}, or whitespace (\verb{ }) between the two role labels, for example \code{"female_x_male"}, \code{"female-male"}, \code{"female_male"}, or \code{"female male"}, in arbitrary order. -To set multiple compositions, use a character vector of such strings.} +To set multiple compositions, use a character vector of such strings. +Unlike \code{include_arbitrary_member_contrast}, this reclassifies the selected +compositions as exchangeable and changes their composition-role coding and +indicators, which is required for composition pooling and DIM +compatibility.} \item{keep_compositions}{Optional observed dyad compositions to keep before exchangeability overrides and pooling. Requires \code{role}. Composition @@ -120,19 +127,45 @@ is applied. \code{"error"} stops with an error and \code{"drop"} removes the ent dyad. Conflicting non-missing roles always cause an error. Ignored when no \code{role} column is supplied.} -\item{seed}{Optional seed for random \verb{.dy_member_contrast_*} sign assignment -in exchangeable dyads. If \code{NULL}, the current R session's RNG state is used.} +\item{seed}{Optional seed for random \verb{.member_contrast_*} sign assignment. +If \code{NULL}, the current R session's RNG state is used.} + +\item{short_colnames}{Whether to use shorter composition-dependent generated +column names when the final data contain one composition. The default \code{TRUE} +omits the redundant composition label from \verb{.is_*} and +\verb{.member_contrast_*} names. \code{FALSE} always retains composition-qualified +names. Other generated column names are unaffected.} + +\item{include_arbitrary_member_contrast}{Whether to also generate arbitrary +\verb{.member_contrast_*} columns for distinguishable compositions. The default +\code{FALSE} generates these columns only for exchangeable compositions. +\code{TRUE} retains distinguishable composition metadata, composition roles, +and role indicators. It only adds the contrast needed to fit an +exchangeability-constrained random-effects model to the same prepared +data. Use \code{set_exchangeable_compositions} instead to reclassify +compositions for pooling or DIM compatibility.} + +\item{add_apim_gmc_predictors}{Whether to add APIM GMC variants for numeric +predictors. \code{TRUE} retains the raw columns and adds \verb{.\{pred\}_gmc} plus its +actor and partner versions, centered over all retained non-missing values +after filtering. Lagged variants use the same mean. Mixed non-numeric +predictors remain raw and are listed in one warning. In longitudinal data, +the mean is observation-weighted. Requires \code{"apim"} in \code{model_types}, at +least one numeric predictor, and resolved \code{temporal_decomposition = "none"}. +Do not use raw and GMC variants together in a model with an intercept.} } \value{ The original data as a tibble with class \code{dyadMLM_data}, -\code{.dy_composition} and \code{.dy_composition_role} factor columns, -\verb{.dy_is_*} numeric indicator columns, composition-specific -numeric \verb{.dy_member_contrast_*} columns coded \code{-1} and \code{1} for the two -members of matching exchangeable dyads and \code{0} otherwise, and a \code{dyadMLM} -attribute containing structural metadata, \code{dyad_compositions}, and +\code{.composition} and \code{.composition_role} factor columns, +\verb{.is_*} numeric indicator columns, and numeric +\verb{.member_contrast_*} columns coded \code{-1} and \code{1} for the two members of +each matching composition and \code{0} otherwise. With one final composition, +their default names omit the composition label. The \code{dyadMLM} attribute +contains structural metadata, \code{dyad_compositions}, and predictor metadata such as \code{temporal_decompositions}, \code{lag1_predictors}, \code{apim_predictors}, and \code{dim_predictors}, as well as \code{dsm_predictors} and -\code{dsm_role_order} when applicable. +\code{dsm_role_order} when applicable. The \code{generated_columns} table records each +package-generated column retained in the returned data. } \description{ Validates dyadic data, records the structural variables, and adds metadata diff --git a/man/recover_exchangeable_covariance.Rd b/man/recover_exchangeable_covariance.Rd index 28ad131d..185edd4f 100644 --- a/man/recover_exchangeable_covariance.Rd +++ b/man/recover_exchangeable_covariance.Rd @@ -52,9 +52,9 @@ derivation, and interpretation, see the \href{https://pascal-kueng.github.io/dyadMLM/articles/apim.html#exchangeable-residual-structure}{exchangeable APIM vignette}. } \details{ -Automatic matching recognizes exact \verb{.dy_member_contrast_*_arbitrary} and -legacy \verb{.dy_diff_*_arbitrary} coefficient names -and first looks for the corresponding \verb{.dy_is_*} shared block. It requires +Automatic matching recognizes the compact \code{.member_contrast_arbitrary} and +composition-qualified \verb{.member_contrast_*_arbitrary} names. It first looks +for the corresponding \verb{.is_*} shared block. It requires the two blocks to use the same grouping factor and the same underlying terms. Most models fitted with \code{dyadMLM}-generated columns therefore need only: @@ -87,15 +87,15 @@ time slope and the same-occasion partner residual covariance: block_pairings = list( dyad = list( shared_block = "(1 + diaryday | coupleID)", - difference_block = "(0 + .dy_member_contrast_assumed_exchangeable_arbitrary | coupleID)", + difference_block = "(0 + .member_contrast_arbitrary | coupleID)", difference_indicator = - ".dy_member_contrast_assumed_exchangeable_arbitrary" + ".member_contrast_arbitrary" ), same_occasion = list( shared_block = "(1 | coupleID:diaryday)", - difference_block = "(0 + .dy_member_contrast_assumed_exchangeable_arbitrary | coupleID:diaryday)", + difference_block = "(0 + .member_contrast_arbitrary | coupleID:diaryday)", difference_indicator = - ".dy_member_contrast_assumed_exchangeable_arbitrary" + ".member_contrast_arbitrary" ) ) ) @@ -197,7 +197,7 @@ if (requireNamespace("glmmTMB", quietly = TRUE)) { model <- glmmTMB::glmmTMB( closeness ~ 1 + us(1 | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID), + us(0 + .member_contrast_arbitrary | coupleID), dispformula = ~ 0, data = example_data ) diff --git a/man/summary.dyadMLM_data.Rd b/man/summary.dyadMLM_data.Rd new file mode 100644 index 00000000..10ac7a87 --- /dev/null +++ b/man/summary.dyadMLM_data.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary_dyadMLM_data.R +\name{summary.dyadMLM_data} +\alias{summary.dyadMLM_data} +\title{Summarize prepared dyadic data} +\usage{ +\method{summary}{dyadMLM_data}(object, ...) +} +\arguments{ +\item{object}{A \code{dyadMLM_data} object returned by \code{\link[=prepare_dyad_data]{prepare_dyad_data()}}.} + +\item{...}{Arguments passed to \code{\link[=summary]{summary()}}.} +} +\value{ +Invisibly, the standard summary of all columns. +} +\description{ +Prints the dyadic structure followed by standard summaries for all columns. +} diff --git a/pkgdown/templates/content-workshop.html b/pkgdown/templates/content-workshop.html index a808d571..209ab2f2 100644 --- a/pkgdown/templates/content-workshop.html +++ b/pkgdown/templates/content-workshop.html @@ -3,13 +3,13 @@

Summer School 2026

Dyadic Data Analysis Workshop

- Conceptual foundations and an applied tutorial for analysing - interdependent dyadic data with R. + Conceptual foundations, an applied tutorial, and hands-on exercises for + analysing interdependent dyadic data with R.

-
+

Part I

@@ -25,13 +25,10 @@

Conceptual foundations

-
+
-
-

Part II

- In development -
+

Part II

Applied tutorial

Data preparation, model fitting, interpretation, diagnostics, @@ -43,6 +40,22 @@

Applied tutorial

+ +
+ +

diff --git a/tests/testthat/test-add_actor_partner_columns.R b/tests/testthat/test-add_actor_partner_columns.R index d77ca2c0..cd4e8f02 100644 --- a/tests/testthat/test-add_actor_partner_columns.R +++ b/tests/testthat/test-add_actor_partner_columns.R @@ -17,21 +17,21 @@ test_that("add_actor_partner_columns creates actor and partner columns", { center_predictors() |> add_actor_partner_columns() - expect_equal(result$.dy_x_actor, result$x) - expect_equal(result$.dy_x_cwp_actor, result$.dy_x_cwp) - expect_equal(result$.dy_x_cbp_actor, result$.dy_x_cbp) - expect_equal(result$.dy_x_partner, c(10, 1, 14, 3, 30, 20, 34, 24)) - expect_equal(result$.dy_x_cwp_partner, c(-2, -1, 2, 1, -2, -2, 2, 2)) - expect_equal(result$.dy_x_cbp_partner, c(-5, -15, -5, -15, 15, 5, 15, 5)) + expect_equal(result$.x_actor, result$x) + expect_equal(result$.x_cwp_actor, result$.x_cwp) + expect_equal(result$.x_cbp_actor, result$.x_cbp) + expect_equal(result$.x_partner, c(10, 1, 14, 3, 30, 20, 34, 24)) + expect_equal(result$.x_cwp_partner, c(-2, -1, 2, 1, -2, -2, 2, 2)) + expect_equal(result$.x_cbp_partner, c(-5, -15, -5, -15, 15, 5, 15, 5)) expect_equal( attr(result, "dyadMLM")$apim_predictors, tibble::tibble( predictor = c("x", "x", "x"), component = c("raw", "cwp", "cbp"), lag = c(0L, 0L, 0L), - source_column = c("x", ".dy_x_cwp", ".dy_x_cbp"), - actor_column = c(".dy_x_actor", ".dy_x_cwp_actor", ".dy_x_cbp_actor"), - partner_column = c(".dy_x_partner", ".dy_x_cwp_partner", ".dy_x_cbp_partner") + source_column = c("x", ".x_cwp", ".x_cbp"), + actor_column = c(".x_actor", ".x_cwp_actor", ".x_cbp_actor"), + partner_column = c(".x_partner", ".x_cwp_partner", ".x_cbp_partner") ) ) expect_equal( @@ -59,18 +59,18 @@ test_that("longitudinal APIM and DIM predictor columns can coexist", { ) expect_true(all(c( - ".dy_x_actor", - ".dy_x_partner", - ".dy_x_cwp_actor", - ".dy_x_cwp_partner", - ".dy_x_cbp_actor", - ".dy_x_cbp_partner", - ".dy_x_dyad_mean_gmc", - ".dy_x_within_dyad_dev", - ".dy_x_cwp_dyad_mean", - ".dy_x_cwp_within_dyad_dev", - ".dy_x_cbp_dyad_mean", - ".dy_x_cbp_within_dyad_dev" + ".x_actor", + ".x_partner", + ".x_cwp_actor", + ".x_cwp_partner", + ".x_cbp_actor", + ".x_cbp_partner", + ".x_dyad_mean_gmc", + ".x_within_dyad_dev", + ".x_cwp_dyad_mean", + ".x_cwp_within_dyad_dev", + ".x_cbp_dyad_mean", + ".x_cbp_within_dyad_dev" ) %in% names(result))) expect_equal( attr(result, "dyadMLM")$dim_predictors$component, @@ -99,8 +99,8 @@ test_that("add_actor_partner_columns preserves rows with missing partner occasio add_actor_partner_columns() expect_equal(nrow(result), nrow(data)) - expect_equal(result$.dy_x_actor, result$x) - expect_equal(result$.dy_x_partner, c(10, 1, NA, 30, 20, 34, 24)) + expect_equal(result$.x_actor, result$x) + expect_equal(result$.x_partner, c(10, 1, NA, 30, 20, 34, 24)) expect_false("x_actor" %in% names(result)) expect_false("x_partner" %in% names(result)) expect_equal( @@ -110,8 +110,8 @@ test_that("add_actor_partner_columns preserves rows with missing partner occasio component = "raw", lag = 0L, source_column = "x", - actor_column = ".dy_x_actor", - partner_column = ".dy_x_partner" + actor_column = ".x_actor", + partner_column = ".x_partner" ) ) }) @@ -134,8 +134,8 @@ test_that("add_actor_partner_columns matches cross-sectional partners", { center_predictors() |> add_actor_partner_columns() - expect_equal(result$.dy_x_actor, result$x) - expect_equal(result$.dy_x_partner, c(10, 1, 30, 20)) + expect_equal(result$.x_actor, result$x) + expect_equal(result$.x_partner, c(10, 1, 30, 20)) }) test_that("add_actor_partner_columns uses generated names for raw predictors", { @@ -157,8 +157,8 @@ test_that("add_actor_partner_columns uses generated names for raw predictors", { center_predictors() |> add_actor_partner_columns() - expect_equal(result$.dy_stress_level_actor, result[["stress level"]]) - expect_equal(result$.dy_stress_level_partner, c(10, 1, 30, 20)) + expect_equal(result$.stress_level_actor, result[["stress level"]]) + expect_equal(result$.stress_level_partner, c(10, 1, 30, 20)) expect_equal( attr(result, "dyadMLM")$apim_predictors, tibble::tibble( @@ -166,8 +166,8 @@ test_that("add_actor_partner_columns uses generated names for raw predictors", { component = "raw", lag = 0L, source_column = "stress level", - actor_column = ".dy_stress_level_actor", - partner_column = ".dy_stress_level_partner" + actor_column = ".stress_level_actor", + partner_column = ".stress_level_partner" ) ) }) @@ -214,8 +214,8 @@ test_that("add_actor_partner_columns preserves measured missingness", { center_predictors() |> add_actor_partner_columns() - expect_equal(result$.dy_x_actor, result$x) - expect_equal(result$.dy_x_partner, c(NA, 1, 30, NA)) + expect_equal(result$.x_actor, result$x) + expect_equal(result$.x_partner, c(NA, 1, 30, NA)) }) test_that("prepare_dyad_data creates actor and partner columns after dropping invalid dyads", { @@ -241,6 +241,6 @@ test_that("prepare_dyad_data creates actor and partner columns after dropping in ) expect_equal(unique(result$dyad_id), c(1, 4)) - expect_equal(result$.dy_x_actor, result$x) - expect_equal(result$.dy_x_partner, c(10, 1, 60, 50)) + expect_equal(result$.x_actor, result$x) + expect_equal(result$.x_partner, c(10, 1, 60, 50)) }) diff --git a/tests/testthat/test-add_dyad_individual_columns.R b/tests/testthat/test-add_dyad_individual_columns.R index 1fbeb9a7..e8a8b37d 100644 --- a/tests/testthat/test-add_dyad_individual_columns.R +++ b/tests/testthat/test-add_dyad_individual_columns.R @@ -17,12 +17,12 @@ test_that("add_dyad_individual_columns creates longitudinal DIM columns", { center_predictors() |> add_dyad_individual_columns() - expect_equal(result$.dy_x_dyad_mean_gmc, c(-11.5, -11.5, -8.5, -8.5, 8, 8, 12, 12)) - expect_equal(result$.dy_x_within_dyad_dev, c(-4.5, 4.5, -5.5, 5.5, -5, 5, -5, 5)) - expect_equal(result$.dy_x_cwp_dyad_mean, c(-1.5, -1.5, 1.5, 1.5, -2, -2, 2, 2)) - expect_equal(result$.dy_x_cwp_within_dyad_dev, c(0.5, -0.5, -0.5, 0.5, 0, 0, 0, 0)) - expect_equal(result$.dy_x_cbp_dyad_mean, c(-10, -10, -10, -10, 10, 10, 10, 10)) - expect_equal(result$.dy_x_cbp_within_dyad_dev, c(-5, 5, -5, 5, -5, 5, -5, 5)) + expect_equal(result$.x_dyad_mean_gmc, c(-11.5, -11.5, -8.5, -8.5, 8, 8, 12, 12)) + expect_equal(result$.x_within_dyad_dev, c(-4.5, 4.5, -5.5, 5.5, -5, 5, -5, 5)) + expect_equal(result$.x_cwp_dyad_mean, c(-1.5, -1.5, 1.5, 1.5, -2, -2, 2, 2)) + expect_equal(result$.x_cwp_within_dyad_dev, c(0.5, -0.5, -0.5, 0.5, 0, 0, 0, 0)) + expect_equal(result$.x_cbp_dyad_mean, c(-10, -10, -10, -10, 10, 10, 10, 10)) + expect_equal(result$.x_cbp_within_dyad_dev, c(-5, 5, -5, 5, -5, 5, -5, 5)) expect_equal( attr(result, "dyadMLM")$dim_predictors, @@ -30,12 +30,12 @@ test_that("add_dyad_individual_columns creates longitudinal DIM columns", { predictor = c("x", "x", "x"), component = c("raw", "cwp", "cbp"), lag = c(0L, 0L, 0L), - source_column = c("x", ".dy_x_cwp", ".dy_x_cbp"), - mean_column = c(".dy_x_dyad_mean_gmc", ".dy_x_cwp_dyad_mean", ".dy_x_cbp_dyad_mean"), + source_column = c("x", ".x_cwp", ".x_cbp"), + mean_column = c(".x_dyad_mean_gmc", ".x_cwp_dyad_mean", ".x_cbp_dyad_mean"), deviation_column = c( - ".dy_x_within_dyad_dev", - ".dy_x_cwp_within_dyad_dev", - ".dy_x_cbp_within_dyad_dev" + ".x_within_dyad_dev", + ".x_cwp_within_dyad_dev", + ".x_cbp_within_dyad_dev" ), dyad_decomposition_level = c("dyad_time", "dyad_time", "dyad") ) @@ -61,13 +61,13 @@ test_that("add_dyad_individual_columns requires complete dyad values for each co center_predictors() |> add_dyad_individual_columns() - expect_false(is.na(result$.dy_x_cwp_dyad_mean[1])) - expect_true(is.na(result$.dy_x_cwp_dyad_mean[3])) - expect_false(is.na(result$.dy_x_dyad_mean_gmc[1])) - expect_true(is.na(result$.dy_x_dyad_mean_gmc[3])) - expect_true(is.na(result$.dy_x_within_dyad_dev[3])) - expect_true(all(is.na(result$.dy_x_cbp_dyad_mean[result$dyad_id == 2]))) - expect_true(all(is.na(result$.dy_x_cbp_within_dyad_dev[result$dyad_id == 2]))) + expect_false(is.na(result$.x_cwp_dyad_mean[1])) + expect_true(is.na(result$.x_cwp_dyad_mean[3])) + expect_false(is.na(result$.x_dyad_mean_gmc[1])) + expect_true(is.na(result$.x_dyad_mean_gmc[3])) + expect_true(is.na(result$.x_within_dyad_dev[3])) + expect_true(all(is.na(result$.x_cbp_dyad_mean[result$dyad_id == 2]))) + expect_true(all(is.na(result$.x_cbp_within_dyad_dev[result$dyad_id == 2]))) }) test_that("add_dyad_individual_columns creates cross-sectional raw DIM columns", { @@ -88,8 +88,8 @@ test_that("add_dyad_individual_columns creates cross-sectional raw DIM columns", center_predictors() |> add_dyad_individual_columns() - expect_equal(result$.dy_x_dyad_mean_gmc, c(-9.75, -9.75, 9.75, 9.75)) - expect_equal(result$.dy_x_within_dyad_dev, c(-4.5, 4.5, -5, 5)) + expect_equal(result$.x_dyad_mean_gmc, c(-9.75, -9.75, 9.75, 9.75)) + expect_equal(result$.x_within_dyad_dev, c(-4.5, 4.5, -5, 5)) expect_equal( attr(result, "dyadMLM")$dim_predictors, @@ -98,8 +98,8 @@ test_that("add_dyad_individual_columns creates cross-sectional raw DIM columns", component = "raw", lag = 0L, source_column = "x", - mean_column = ".dy_x_dyad_mean_gmc", - deviation_column = ".dy_x_within_dyad_dev", + mean_column = ".x_dyad_mean_gmc", + deviation_column = ".x_within_dyad_dev", dyad_decomposition_level = "dyad" ) ) @@ -152,9 +152,9 @@ test_that("DIM construction allows one role-supplied exchangeable composition", seed = 123 ) - expect_true(".dy_x_dyad_mean_gmc" %in% names(result)) - expect_true(".dy_x_within_dyad_dev" %in% names(result)) - expect_equal(unique(as.character(result$.dy_composition)), "female_x_female") + expect_true(".x_dyad_mean_gmc" %in% names(result)) + expect_true(".x_within_dyad_dev" %in% names(result)) + expect_equal(unique(as.character(result$.composition)), "female_x_female") expect_equal(attr(result, "dyadMLM")$dyad_compositions$dyad_type, "exchangeable") }) @@ -175,10 +175,10 @@ test_that("raw cross-sectional DIM requires complete dyad values", { seed = 123 ) - expect_true(all(is.na(result$.dy_x_dyad_mean_gmc[result$dyad_id == 1]))) - expect_true(all(is.na(result$.dy_x_within_dyad_dev[result$dyad_id == 1]))) - expect_equal(result$.dy_x_dyad_mean_gmc[result$dyad_id == 2], c(0, 0)) - expect_equal(result$.dy_x_within_dyad_dev[result$dyad_id == 2], c(-5, 5)) + expect_true(all(is.na(result$.x_dyad_mean_gmc[result$dyad_id == 1]))) + expect_true(all(is.na(result$.x_within_dyad_dev[result$dyad_id == 1]))) + expect_equal(result$.x_dyad_mean_gmc[result$dyad_id == 2], c(0, 0)) + expect_equal(result$.x_within_dyad_dev[result$dyad_id == 2], c(-5, 5)) }) test_that("prepare_dyad_data creates DIM columns without APIM columns", { @@ -198,7 +198,7 @@ test_that("prepare_dyad_data creates DIM columns without APIM columns", { seed = 123 ) - expect_true(".dy_x_dyad_mean_gmc" %in% names(result)) + expect_true(".x_dyad_mean_gmc" %in% names(result)) expect_false("x_actor" %in% names(result)) expect_false("x_partner" %in% names(result)) }) @@ -220,7 +220,8 @@ test_that("DIM construction errors for distinguishable dyads", { predictors = x, model_types = "dim", temporal_decomposition = "none", - seed = 123 + seed = 123, + include_arbitrary_member_contrast = TRUE ), "female_x_male \\(distinguishable, n_dyads = 2\\)" ) @@ -291,8 +292,8 @@ test_that("longitudinal DIM constructs undecomposed raw predictor scores", { seed = 123 ) - expect_equal(result$.dy_x_dyad_mean_gmc, c(-11.5, -11.5, -8.5, -8.5, 8, 8, 12, 12)) - expect_equal(result$.dy_x_within_dyad_dev, c(-4.5, 4.5, -5.5, 5.5, -5, 5, -5, 5)) + expect_equal(result$.x_dyad_mean_gmc, c(-11.5, -11.5, -8.5, -8.5, 8, 8, 12, 12)) + expect_equal(result$.x_within_dyad_dev, c(-4.5, 4.5, -5.5, 5.5, -5, 5, -5, 5)) expect_equal(attr(result, "dyadMLM")$dim_predictors$component, "raw") expect_equal(attr(result, "dyadMLM")$dim_predictors$dyad_decomposition_level, "dyad_time") }) diff --git a/tests/testthat/test-add_dyadic_score_columns.R b/tests/testthat/test-add_dyadic_score_columns.R index e66573aa..8a7d3616 100644 --- a/tests/testthat/test-add_dyadic_score_columns.R +++ b/tests/testthat/test-add_dyadic_score_columns.R @@ -18,15 +18,15 @@ test_that("DSM constructs directional cross-sectional predictor scores", { temporal_decomposition = "none" ) - expect_equal(result$.dy_dsm_role_contrast, c(-0.5, 0.5, 0.5, -0.5)) - expect_equal(result$.dy_x_dyad_mean_gmc, c(-2.5, -2.5, 2.5, 2.5)) - expect_equal(result$.dy_x_within_dyad_diff, rep(4, 4)) - expect_false(".dy_x_within_dyad_dev" %in% names(result)) - expect_false(any(startsWith(names(result), ".dy_y_"))) + expect_equal(result$.dsm_role_contrast, c(-0.5, 0.5, 0.5, -0.5)) + expect_equal(result$.x_dyad_mean_gmc, c(-2.5, -2.5, 2.5, 2.5)) + expect_equal(result$.x_within_dyad_diff, rep(4, 4)) + expect_false(".x_within_dyad_dev" %in% names(result)) + expect_false(any(startsWith(names(result), ".y_"))) meta <- attr(result, "dyadMLM") expect_equal(meta$dsm_role_order, c("female", "male")) - expect_equal(meta$dsm_role_contrast_column, ".dy_dsm_role_contrast") + expect_equal(meta$dsm_role_contrast_column, ".dsm_role_contrast") expect_equal( meta$dsm_predictors, tibble::tibble( @@ -34,8 +34,8 @@ test_that("DSM constructs directional cross-sectional predictor scores", { component = "raw", lag = 0L, source_column = "x", - mean_column = ".dy_x_dyad_mean_gmc", - difference_column = ".dy_x_within_dyad_diff", + mean_column = ".x_dyad_mean_gmc", + difference_column = ".x_within_dyad_diff", dyad_decomposition_level = "dyad" ) ) @@ -69,16 +69,16 @@ test_that("reversing DSM role order reverses directional columns only", { ) expect_equal( - male_minus_female$.dy_x_dyad_mean_gmc, - female_minus_male$.dy_x_dyad_mean_gmc + male_minus_female$.x_dyad_mean_gmc, + female_minus_male$.x_dyad_mean_gmc ) expect_equal( - male_minus_female$.dy_x_within_dyad_diff, - -female_minus_male$.dy_x_within_dyad_diff + male_minus_female$.x_within_dyad_diff, + -female_minus_male$.x_within_dyad_diff ) expect_equal( - male_minus_female$.dy_dsm_role_contrast, - -female_minus_male$.dy_dsm_role_contrast + male_minus_female$.dsm_role_contrast, + -female_minus_male$.dsm_role_contrast ) }) @@ -109,8 +109,8 @@ test_that("DSM columns reproduce APIM fixed and random effects", { P_m = 0.3 ) mu_x <- unique( - (result$.dy_x_actor + result$.dy_x_partner) / 2 - - result$.dy_x_dyad_mean_gmc + (result$.x_actor + result$.x_partner) / 2 - + result$.x_dyad_mean_gmc ) a11 <- (apim[["A_f"]] + apim[["P_f"]] + @@ -138,19 +138,19 @@ test_that("DSM columns reproduce APIM fixed and random effects", { apim_prediction <- ifelse( result$role == "female", - apim[["alpha_f"]] + apim[["A_f"]] * result$.dy_x_actor + - apim[["P_f"]] * result$.dy_x_partner, - apim[["alpha_m"]] + apim[["A_m"]] * result$.dy_x_actor + - apim[["P_m"]] * result$.dy_x_partner + apim[["alpha_f"]] + apim[["A_f"]] * result$.x_actor + + apim[["P_f"]] * result$.x_partner, + apim[["alpha_m"]] + apim[["A_m"]] * result$.x_actor + + apim[["P_m"]] * result$.x_partner ) dsm_prediction <- dsm[["a10"]] + - dsm[["a11"]] * result$.dy_x_dyad_mean_gmc + - dsm[["a12"]] * result$.dy_x_within_dyad_diff + - result$.dy_dsm_role_contrast * ( + dsm[["a11"]] * result$.x_dyad_mean_gmc + + dsm[["a12"]] * result$.x_within_dyad_diff + + result$.dsm_role_contrast * ( dsm[["a20"]] + - dsm[["a21"]] * result$.dy_x_dyad_mean_gmc + - dsm[["a22"]] * result$.dy_x_within_dyad_diff + dsm[["a21"]] * result$.x_dyad_mean_gmc + + dsm[["a22"]] * result$.x_within_dyad_diff ) expect_equal(dsm_prediction, apim_prediction) @@ -182,9 +182,9 @@ test_that("DSM requires both predictor values for dyadic scores", { dsm_role_order = c("female", "male") ) - expect_true(all(is.na(result$.dy_x_dyad_mean_gmc[result$dyad_id == 1]))) - expect_true(all(is.na(result$.dy_x_within_dyad_diff[result$dyad_id == 1]))) - expect_equal(result$.dy_x_within_dyad_diff[result$dyad_id == 2], c(4, 4)) + expect_true(all(is.na(result$.x_dyad_mean_gmc[result$dyad_id == 1]))) + expect_true(all(is.na(result$.x_within_dyad_diff[result$dyad_id == 1]))) + expect_equal(result$.x_within_dyad_diff[result$dyad_id == 2], c(4, 4)) }) test_that("DSM creates a role contrast without predictors", { @@ -203,7 +203,7 @@ test_that("DSM creates a role contrast without predictors", { dsm_role_order = c("female", "male") ) - expect_equal(result$.dy_dsm_role_contrast, c(0.5, -0.5, 0.5, -0.5)) + expect_equal(result$.dsm_role_contrast, c(0.5, -0.5, 0.5, -0.5)) expect_equal( attr(result, "dyadMLM")$dsm_predictors, tibble::tibble( @@ -217,13 +217,14 @@ test_that("DSM creates a role contrast without predictors", { ) ) - generated <- dyad_generated_columns(attr(result, "dyadMLM")) - expect_equal(generated$column, ".dy_dsm_role_contrast") + generated <- dyad_generated_columns(attr(result, "dyadMLM")) |> + dplyr::filter(.data$model_family == "dsm") + expect_equal(generated$column, ".dsm_role_contrast") printed <- capture.output(print(result, n = 2)) expect_true(any(grepl("DSM direction: female - male", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_dsm_role_contrast", printed, fixed = TRUE))) - expect_false(any(grepl(".dy_{pred}_dyad_mean", printed, fixed = TRUE))) + expect_true(any(grepl(".dsm_role_contrast", printed, fixed = TRUE))) + expect_false(any(grepl(".{pred}_dyad_mean", printed, fixed = TRUE))) }) test_that("DSM keeps multiple predictors and metadata aligned", { @@ -245,8 +246,8 @@ test_that("DSM keeps multiple predictors and metadata aligned", { dsm_role_order = c("female", "male") ) - expect_equal(result$.dy_x_within_dyad_diff, rep(4, 4)) - expect_equal(result$.dy_stress_level_within_dyad_diff, c(6, 6, 8, 8)) + expect_equal(result$.x_within_dyad_diff, rep(4, 4)) + expect_equal(result$.stress_level_within_dyad_diff, c(6, 6, 8, 8)) expect_false(any(grepl("within_dyad_dev", names(result), fixed = TRUE))) meta <- attr(result, "dyadMLM")$dsm_predictors @@ -254,8 +255,8 @@ test_that("DSM keeps multiple predictors and metadata aligned", { expect_equal( meta$difference_column, c( - ".dy_x_within_dyad_diff", - ".dy_stress_level_within_dyad_diff" + ".x_within_dyad_diff", + ".stress_level_within_dyad_diff" ) ) }) @@ -280,13 +281,13 @@ test_that("DSM constructs longitudinal raw, CWP, and CBP scores", { dsm_role_order = c("female", "male") ) - expect_equal(result$.dy_x_dyad_mean_gmc, rep(c(-4, -1, 1, 4), each = 2)) - expect_equal(result$.dy_x_within_dyad_diff, rep(c(2, 4, 4, 6), each = 2)) - expect_equal(result$.dy_x_cwp_dyad_mean, rep(c(-1.5, -1.5, 1.5, 1.5), 2)) - expect_equal(result$.dy_x_cwp_within_dyad_diff, rep(c(-1, -1, 1, 1), 2)) - expect_equal(result$.dy_x_cbp_dyad_mean, c(rep(-2.5, 4), rep(2.5, 4))) - expect_equal(result$.dy_x_cbp_within_dyad_diff, c(rep(3, 4), rep(5, 4))) - expect_equal(result$.dy_dsm_role_contrast, rep(c(0.5, -0.5), 4)) + expect_equal(result$.x_dyad_mean_gmc, rep(c(-4, -1, 1, 4), each = 2)) + expect_equal(result$.x_within_dyad_diff, rep(c(2, 4, 4, 6), each = 2)) + expect_equal(result$.x_cwp_dyad_mean, rep(c(-1.5, -1.5, 1.5, 1.5), 2)) + expect_equal(result$.x_cwp_within_dyad_diff, rep(c(-1, -1, 1, 1), 2)) + expect_equal(result$.x_cbp_dyad_mean, c(rep(-2.5, 4), rep(2.5, 4))) + expect_equal(result$.x_cbp_within_dyad_diff, c(rep(3, 4), rep(5, 4))) + expect_equal(result$.dsm_role_contrast, rep(c(0.5, -0.5), 4)) expect_false(any(grepl("within_dyad_dev", names(result), fixed = TRUE))) meta <- attr(result, "dyadMLM")$dsm_predictors @@ -317,16 +318,16 @@ test_that("DSM returns missing CWP scores for an incomplete predictor pair", { incomplete_occasion <- result$dyad_id == 1 & result$time == 1 complete_occasion <- result$dyad_id == 1 & result$time == 2 - expect_true(all(is.na(result$.dy_x_dyad_mean_gmc[incomplete_occasion]))) - expect_true(all(is.na(result$.dy_x_within_dyad_diff[incomplete_occasion]))) - expect_false(any(is.na(result$.dy_x_dyad_mean_gmc[complete_occasion]))) - expect_false(any(is.na(result$.dy_x_within_dyad_diff[complete_occasion]))) - expect_true(all(is.na(result$.dy_x_cwp_dyad_mean[incomplete_occasion]))) - expect_true(all(is.na(result$.dy_x_cwp_within_dyad_diff[incomplete_occasion]))) - expect_false(any(is.na(result$.dy_x_cwp_dyad_mean[complete_occasion]))) - expect_false(any(is.na(result$.dy_x_cwp_within_dyad_diff[complete_occasion]))) - expect_false(any(is.na(result$.dy_x_cbp_dyad_mean[result$dyad_id == 1]))) - expect_false(any(is.na(result$.dy_x_cbp_within_dyad_diff[result$dyad_id == 1]))) + expect_true(all(is.na(result$.x_dyad_mean_gmc[incomplete_occasion]))) + expect_true(all(is.na(result$.x_within_dyad_diff[incomplete_occasion]))) + expect_false(any(is.na(result$.x_dyad_mean_gmc[complete_occasion]))) + expect_false(any(is.na(result$.x_within_dyad_diff[complete_occasion]))) + expect_true(all(is.na(result$.x_cwp_dyad_mean[incomplete_occasion]))) + expect_true(all(is.na(result$.x_cwp_within_dyad_diff[incomplete_occasion]))) + expect_false(any(is.na(result$.x_cwp_dyad_mean[complete_occasion]))) + expect_false(any(is.na(result$.x_cwp_within_dyad_diff[complete_occasion]))) + expect_false(any(is.na(result$.x_cbp_dyad_mean[result$dyad_id == 1]))) + expect_false(any(is.na(result$.x_cbp_within_dyad_diff[result$dyad_id == 1]))) }) test_that("DSM and APIM predictor columns can coexist", { @@ -348,11 +349,11 @@ test_that("DSM and APIM predictor columns can coexist", { ) expect_true(all(c( - ".dy_x_actor", - ".dy_x_partner", - ".dy_x_dyad_mean_gmc", - ".dy_x_within_dyad_diff", - ".dy_dsm_role_contrast" + ".x_actor", + ".x_partner", + ".x_dyad_mean_gmc", + ".x_within_dyad_diff", + ".dsm_role_contrast" ) %in% names(result))) }) @@ -377,8 +378,8 @@ test_that("DSM constructs raw longitudinal predictor scores", { temporal_decomposition = "none" ) - expect_equal(result$.dy_x_dyad_mean_gmc, rep(c(-4, -1, 1, 4), each = 2)) - expect_equal(result$.dy_x_within_dyad_diff, rep(c(2, 4, 4, 6), each = 2)) + expect_equal(result$.x_dyad_mean_gmc, rep(c(-4, -1, 1, 4), each = 2)) + expect_equal(result$.x_within_dyad_diff, rep(c(2, 4, 4, 6), each = 2)) expect_equal(attr(result, "dyadMLM")$dsm_predictors$component, "raw") expect_equal(attr(result, "dyadMLM")$dsm_predictors$dyad_decomposition_level, "dyad_time") }) diff --git a/tests/testthat/test-add_temporal_lag_columns.R b/tests/testthat/test-add_temporal_lag_columns.R index 89d45446..df877d1a 100644 --- a/tests/testthat/test-add_temporal_lag_columns.R +++ b/tests/testthat/test-add_temporal_lag_columns.R @@ -20,23 +20,23 @@ test_that("lag predictors are matched at exactly time minus one", { ) expect_equal(result$row_id, data$row_id) - expect_equal(result$.dy_x_lag1, c(21, NA, NA, NA, NA, NA, 31, NA, 22, 32)) + expect_equal(result$.x_lag1, c(21, NA, NA, NA, NA, NA, 31, NA, 22, 32)) - prior_cwp <- result$.dy_x_cwp[match( + prior_cwp <- result$.x_cwp[match( paste(result$dyad_id, result$person_id, result$time - 1), paste(result$dyad_id, result$person_id, result$time) )] - expect_equal(result$.dy_x_cwp_lag1, prior_cwp) - expect_equal(result$.dy_x_actor_lag1, result$.dy_x_lag1) + expect_equal(result$.x_cwp_lag1, prior_cwp) + expect_equal(result$.x_actor_lag1, result$.x_lag1) partner_id <- c(A = "B", B = "A", C = "D", D = "C")[result$person_id] - expected_partner_lag <- result$.dy_x_lag1[match( + expected_partner_lag <- result$.x_lag1[match( paste(result$dyad_id, result$time, partner_id), paste(result$dyad_id, result$time, result$person_id) )] - expect_equal(result$.dy_x_partner_lag1, expected_partner_lag) + expect_equal(result$.x_partner_lag1, expected_partner_lag) - expect_false(any(grepl(".dy_z.*lag1", names(result)))) + expect_false(any(grepl(".z.*lag1", names(result)))) expect_false(any(grepl("cbp.*lag1", names(result)))) expect_equal(attr(result, "dyadMLM")$lag1_predictors, "x") expect_equal( @@ -49,17 +49,17 @@ test_that("lag predictors are matched at exactly time minus one", { expect_equal( generated_lags$column, c( - ".dy_x_lag1", - ".dy_x_cwp_lag1", - ".dy_x_actor_lag1", - ".dy_x_cwp_actor_lag1", - ".dy_x_partner_lag1", - ".dy_x_cwp_partner_lag1" + ".x_lag1", + ".x_cwp_lag1", + ".x_actor_lag1", + ".x_cwp_actor_lag1", + ".x_partner_lag1", + ".x_cwp_partner_lag1" ) ) printed <- capture.output(print(result, n = 1)) - expect_true(any(grepl(".dy_{pred}_actor_lag1", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_actor_lag1", printed, fixed = TRUE))) expect_true(any(grepl("lag-1 APIM actor predictor", printed, fixed = TRUE))) }) @@ -86,8 +86,8 @@ test_that("lag predictors handle a missing row for one member", { result$person_id == "A" & result$time == 3 - expect_true(is.na(result$.dy_x_actor_lag1[member_a_time_3])) - expect_equal(result$.dy_x_partner_lag1[member_a_time_3], 21) + expect_true(is.na(result$.x_actor_lag1[member_a_time_3])) + expect_equal(result$.x_partner_lag1[member_a_time_3], 21) }) test_that("lag predictors create DIM and DSM model-ready columns", { @@ -110,17 +110,42 @@ test_that("lag predictors create DIM and DSM model-ready columns", { ) expect_true(all(c( - ".dy_x_dyad_mean_gmc_lag1", - ".dy_x_within_dyad_dev_lag1", - ".dy_x_cwp_dyad_mean_lag1", - ".dy_x_cwp_within_dyad_dev_lag1" + ".x_dyad_mean_gmc_lag1", + ".x_within_dyad_dev_lag1", + ".x_cwp_dyad_mean_lag1", + ".x_cwp_within_dyad_dev_lag1" ) %in% names(dim_result))) - expect_true(all(is.na(dim_result$.dy_x_dyad_mean_gmc_lag1[dim_result$time == 1]))) + expect_true(all(is.na(dim_result$.x_dyad_mean_gmc_lag1[dim_result$time == 1]))) expect_equal( - dim_result$.dy_x_within_dyad_dev_lag1[dim_result$time > 1], + dim_result$.x_within_dyad_dev_lag1[dim_result$time > 1], rep(c(-0.5, 0.5), 4) ) + dim_generated_lags <- dyad_generated_columns(attr(dim_result, "dyadMLM")) |> + dplyr::filter(.data$model_family == "dim", .data$lag == 1L) |> + dplyr::select("component", "column_role", "column", "source_column") |> + dplyr::arrange(.data$column) + expect_equal( + dim_generated_lags, + tibble::tibble( + component = c("cwp", "cwp", "raw", "raw"), + column_role = c( + "dyad_mean", "within_dyad_deviation", + "dyad_mean", "within_dyad_deviation" + ), + column = c( + ".x_cwp_dyad_mean_lag1", + ".x_cwp_within_dyad_dev_lag1", + ".x_dyad_mean_gmc_lag1", + ".x_within_dyad_dev_lag1" + ), + source_column = c( + ".x_cwp_lag1", ".x_cwp_lag1", + ".x_lag1", ".x_lag1" + ) + ) + ) + distinguishable <- dplyr::mutate( exchangeable, role = ifelse(.data$person_id == "A", "first", "second") @@ -139,15 +164,40 @@ test_that("lag predictors create DIM and DSM model-ready columns", { ) expect_true(all(c( - ".dy_x_dyad_mean_gmc_lag1", - ".dy_x_within_dyad_diff_lag1", - ".dy_x_cwp_dyad_mean_lag1", - ".dy_x_cwp_within_dyad_diff_lag1" + ".x_dyad_mean_gmc_lag1", + ".x_within_dyad_diff_lag1", + ".x_cwp_dyad_mean_lag1", + ".x_cwp_within_dyad_diff_lag1" ) %in% names(dsm_result))) expect_equal( - dsm_result$.dy_x_within_dyad_diff_lag1[dsm_result$time > 1], + dsm_result$.x_within_dyad_diff_lag1[dsm_result$time > 1], rep(-1, 8) ) + + dsm_generated_lags <- dyad_generated_columns(attr(dsm_result, "dyadMLM")) |> + dplyr::filter(.data$model_family == "dsm", .data$lag == 1L) |> + dplyr::select("component", "column_role", "column", "source_column") |> + dplyr::arrange(.data$column) + expect_equal( + dsm_generated_lags, + tibble::tibble( + component = c("cwp", "cwp", "raw", "raw"), + column_role = c( + "dyad_mean", "dyad_difference", + "dyad_mean", "dyad_difference" + ), + column = c( + ".x_cwp_dyad_mean_lag1", + ".x_cwp_within_dyad_diff_lag1", + ".x_dyad_mean_gmc_lag1", + ".x_within_dyad_diff_lag1" + ), + source_column = c( + ".x_cwp_lag1", ".x_cwp_lag1", + ".x_lag1", ".x_lag1" + ) + ) + ) }) test_that("lag predictors work without temporal centering", { @@ -170,7 +220,7 @@ test_that("lag predictors work without temporal centering", { seed = 123 ) - expect_equal(result$.dy_x_lag1, c(NA, NA, "a", "b", NA, NA, "e", "f")) - expect_equal(result$.dy_x_actor_lag1, result$.dy_x_lag1) + expect_equal(result$.x_lag1, c(NA, NA, "a", "b", NA, NA, "e", "f")) + expect_equal(result$.x_actor_lag1, result$.x_lag1) expect_false(any(grepl("cwp.*lag1", names(result)))) }) diff --git a/tests/testthat/test-apim-gmc-predictors.R b/tests/testthat/test-apim-gmc-predictors.R new file mode 100644 index 00000000..9ab7aa53 --- /dev/null +++ b/tests/testthat/test-apim-gmc-predictors.R @@ -0,0 +1,403 @@ +test_that("omitting APIM GMC is identical to requesting FALSE", { + data <- data.frame( + dyad_id = rep(1:2, each = 2), + person_id = LETTERS[1:4], + x = c(1, 3, 5, 9) + ) + + omitted <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + predictors = x, + model_types = "apim", + seed = 123 + ) + explicit_false <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + predictors = x, + model_types = "apim", + seed = 123, + add_apim_gmc_predictors = FALSE + ) + + expect_identical(explicit_false, omitted) +}) + +test_that("APIM GMC validates its argument and preparation context", { + cross <- data.frame( + dyad_id = rep(1:2, each = 2), + person_id = LETTERS[1:4], + x = 1:4 + ) + + for (value in list(NA, c(TRUE, FALSE), "yes", 1)) { + expect_error( + prepare_dyad_data( + cross, + dyad = dyad_id, + member = person_id, + predictors = x, + add_apim_gmc_predictors = value + ), + "`add_apim_gmc_predictors` must be .*TRUE.* or .*FALSE" + ) + } + + expect_error( + prepare_dyad_data( + cross, + dyad = dyad_id, + member = person_id, + predictors = x, + model_types = "none", + add_apim_gmc_predictors = TRUE + ), + '`model_types` includes "apim"', + fixed = TRUE + ) + + expect_error( + prepare_dyad_data( + cross, + dyad = dyad_id, + member = person_id, + model_types = "apim", + add_apim_gmc_predictors = TRUE + ), + "`predictors`", + fixed = TRUE + ) + + nonnumeric <- dplyr::mutate(cross, x = factor(.data$x)) + expect_error( + prepare_dyad_data( + nonnumeric, + dyad = dyad_id, + member = person_id, + predictors = x, + model_types = "apim", + add_apim_gmc_predictors = TRUE + ), + "at least one numeric variable selected by `predictors`", + fixed = TRUE + ) + + longitudinal <- data.frame( + dyad_id = rep(1:2, each = 4), + person_id = rep(c("A", "B"), 4), + time = rep(rep(1:2, each = 2), 2), + x = 1:8 + ) + expect_error( + prepare_dyad_data( + longitudinal, + dyad = dyad_id, + member = person_id, + time = time, + predictors = x, + model_types = "apim", + add_apim_gmc_predictors = TRUE + ), + '`temporal_decomposition = "none"` after `"auto"` is resolved', + fixed = TRUE + ) +}) + +test_that("APIM GMC uses all retained non-missing observations", { + data <- data.frame( + dyad_id = rep(1:4, each = 2), + person_id = LETTERS[1:8], + role = c( + "female", "male", + "female", "male", + "female", "male", + "female", "female" + ), + x = c(1, 3, 5, NA, 9, 11, 100, 200), + all_missing = rep(NA_real_, 8), + category = factor(rep(c("low", "high"), 4)), + flag = rep(c(TRUE, FALSE), 4) + ) + + expect_warning( + result <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + role = role, + predictors = c(x, all_missing, category, flag), + model_types = "apim", + keep_compositions = "female-male", + add_apim_gmc_predictors = TRUE + ), + "non-numeric predictor\\(s\\): `category`, `flag`" + ) + + expect_equal(result$dyad_id, rep(1:3, each = 2)) + + grand_mean <- mean(c(1, 3, 5, NA, 9, 11), na.rm = TRUE) + expected_gmc <- result$x - grand_mean + partner_rows <- c(2L, 1L, 4L, 3L, 6L, 5L) + + expect_equal(result$.x_gmc, expected_gmc) + expect_equal(result$.x_gmc_actor, expected_gmc) + expect_equal(result$.x_gmc_partner, expected_gmc[partner_rows]) + expect_equal(result$.x_actor, result$x) + expect_equal(result$.x_partner, result$x[partner_rows]) + expect_equal(mean(result$.x_gmc, na.rm = TRUE), 0) + expect_true(is.na(result$.x_gmc[result$dyad_id == 2 & result$role == "male"])) + + expect_true(all(is.na(result$.all_missing_gmc))) + expect_true(all(is.na(result$.all_missing_gmc_actor))) + expect_true(all(is.na(result$.all_missing_gmc_partner))) + + expect_equal(result$.category_actor, result$category) + expect_equal(result$.category_partner, result$category[partner_rows]) + expect_false(any(grepl("^\\.category_gmc", names(result)))) + expect_equal(result$.flag_actor, result$flag) + expect_equal(result$.flag_partner, result$flag[partner_rows]) + expect_false(any(grepl("^\\.flag_gmc", names(result)))) +}) + +test_that("undecomposed ILD GMC weights observations rather than person means", { + data <- data.frame( + dyad_id = c(1, 1, 1, 1, 2, 2), + person_id = c("A", "A", "A", "B", "C", "D"), + time = c(1, 2, 3, 1, 1, 1), + x = c(0, 0, 30, 20, 40, 60) + ) + + result <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + time = time, + predictors = x, + model_types = "apim", + temporal_decomposition = "none", + seed = 123, + add_apim_gmc_predictors = TRUE + ) + + observation_mean <- mean(data$x) + person_mean <- mean(c(10, 20, 40, 60)) + expect_equal(result$.x_gmc, result$x - observation_mean) + expect_false(isTRUE(all.equal(result$.x_gmc, result$x - person_mean))) +}) + +test_that("APIM GMC lags retain the contemporaneous centering constant", { + data <- data.frame( + dyad_id = rep(1:2, each = 6), + person_id = rep(c("A", "B"), 6), + time = rep(rep(1:3, each = 2), 2), + x = c(0, 10, 2, 14, 8, 20, 30, 50, 31, 55, 40, 80) + ) + + result <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + time = time, + predictors = x, + lag1_predictors = x, + model_types = "apim", + temporal_decomposition = "none", + seed = 123, + add_apim_gmc_predictors = TRUE + ) + + grand_mean <- mean(data$x) + expect_equal(result$.x_gmc, result$x - grand_mean) + expect_equal(result$.x_gmc_lag1, result$.x_lag1 - grand_mean) + expect_equal(result$.x_gmc_actor_lag1, result$.x_gmc_lag1) + + partner_id <- c(A = "B", B = "A")[result$person_id] + partner_rows <- match( + paste(result$dyad_id, result$time, partner_id), + paste(result$dyad_id, result$time, result$person_id) + ) + expect_equal( + result$.x_gmc_partner_lag1, + result$.x_gmc_lag1[partner_rows] + ) + + generated_lags <- dyad_generated_columns(attr(result, "dyadMLM")) |> + dplyr::filter(.data$component == "gmc", .data$lag == 1L) + expected_columns <- c( + ".x_gmc_lag1", + ".x_gmc_actor_lag1", + ".x_gmc_partner_lag1" + ) + generated_lags <- generated_lags[ + match(expected_columns, generated_lags$column), + ] + expect_equal(generated_lags$column, expected_columns) + expect_equal(generated_lags$model_family, rep("apim", 3)) + expect_equal(generated_lags$column_role, c("source", "actor", "partner")) + expect_equal(generated_lags$column_centering, rep("grand_mean", 3)) +}) + +test_that("APIM GMC does not enter DIM or DSM decompositions", { + exchangeable <- data.frame( + dyad_id = rep(1:3, each = 2), + person_id = LETTERS[1:6], + x = c(1, 4, 5, 9, 10, 15) + ) + dim_default <- prepare_dyad_data( + exchangeable, + dyad = dyad_id, + member = person_id, + predictors = x, + model_types = c("apim", "dim"), + seed = 123 + ) + dim_gmc <- prepare_dyad_data( + exchangeable, + dyad = dyad_id, + member = person_id, + predictors = x, + model_types = c("apim", "dim"), + seed = 123, + add_apim_gmc_predictors = TRUE + ) + + dim_columns <- unlist( + attr(dim_default, "dyadMLM")$dim_predictors[ + c("mean_column", "deviation_column") + ], + use.names = FALSE + ) + expect_equal( + unname(as.list(dim_gmc)[dim_columns]), + unname(as.list(dim_default)[dim_columns]) + ) + expect_equal( + attr(dim_gmc, "dyadMLM")$dim_predictors, + attr(dim_default, "dyadMLM")$dim_predictors + ) + expect_false(any( + attr(dim_gmc, "dyadMLM")$dim_predictors$component == "gmc" + )) + + distinguishable <- data.frame( + dyad_id = rep(1:3, each = 2), + person_id = LETTERS[1:6], + role = rep(c("female", "male"), 3), + x = c(1, 4, 5, 9, 10, 15) + ) + dsm_default <- prepare_dyad_data( + distinguishable, + dyad = dyad_id, + member = person_id, + role = role, + predictors = x, + model_types = c("apim", "dsm"), + dsm_role_order = c("female", "male") + ) + dsm_gmc <- prepare_dyad_data( + distinguishable, + dyad = dyad_id, + member = person_id, + role = role, + predictors = x, + model_types = c("apim", "dsm"), + dsm_role_order = c("female", "male"), + add_apim_gmc_predictors = TRUE + ) + + dsm_columns <- unlist( + attr(dsm_default, "dyadMLM")$dsm_predictors[ + c("mean_column", "difference_column") + ], + use.names = FALSE + ) + expect_equal( + unname(as.list(dsm_gmc)[dsm_columns]), + unname(as.list(dsm_default)[dsm_columns]) + ) + expect_equal( + attr(dsm_gmc, "dyadMLM")$dsm_predictors, + attr(dsm_default, "dyadMLM")$dsm_predictors + ) + expect_false(any( + attr(dsm_gmc, "dyadMLM")$dsm_predictors$component == "gmc" + )) +}) + +test_that("APIM GMC columns are classified and printed as grand-mean centered", { + data <- data.frame( + dyad_id = rep(1:2, each = 2), + person_id = LETTERS[1:4], + x = c(1, 3, 5, 9) + ) + result <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + predictors = x, + model_types = "apim", + seed = 123, + add_apim_gmc_predictors = TRUE + ) + + generated <- dyad_generated_columns(attr(result, "dyadMLM")) |> + dplyr::filter(.data$component == "gmc") + expected_columns <- c(".x_gmc", ".x_gmc_actor", ".x_gmc_partner") + generated <- generated[match(expected_columns, generated$column), ] + + expect_equal(generated$column, expected_columns) + expect_equal(generated$model_family, rep("apim", 3)) + expect_equal(generated$variable_role, rep("predictor", 3)) + expect_equal(generated$column_role, c("source", "actor", "partner")) + expect_equal(generated$temporal_decomposition, rep("none", 3)) + expect_equal(generated$column_centering, rep("grand_mean", 3)) + + printed <- capture.output(print(result, n = 1)) + expect_true(any(grepl(".{pred}_gmc", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_gmc_actor", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_gmc_partner", printed, fixed = TRUE))) + expect_true(any(grepl("grand-mean", printed, fixed = TRUE))) +}) + +test_that("APIM GMC generated-column collisions fail before construction", { + data <- data.frame( + dyad_id = rep(1:2, each = 2), + person_id = LETTERS[1:4], + x = c(1, 3, 5, 9) + ) + + for (target in c(".x_gmc", ".x_gmc_actor", ".x_gmc_partner")) { + conflicting <- data + conflicting[[target]] <- seq_len(nrow(conflicting)) + + expect_error( + prepare_dyad_data( + conflicting, + dyad = dyad_id, + member = person_id, + predictors = x, + model_types = "apim", + seed = 123, + add_apim_gmc_predictors = TRUE + ), + paste0("Generated-column collision.*", gsub("\\.", "\\\\.", target)) + ) + } + + convergent <- dplyr::mutate(data, x_gmc = .data$x + 100) + expect_error( + prepare_dyad_data( + convergent, + dyad = dyad_id, + member = person_id, + predictors = c(x, x_gmc), + model_types = "apim", + seed = 123, + add_apim_gmc_predictors = TRUE + ), + "Generated-column collision.*\\.x_gmc_actor" + ) +}) diff --git a/tests/testthat/test-backtransform-residual-covariance.R b/tests/testthat/test-backtransform-residual-covariance.R index 384736ad..79f58c43 100644 --- a/tests/testthat/test-backtransform-residual-covariance.R +++ b/tests/testthat/test-backtransform-residual-covariance.R @@ -368,7 +368,7 @@ test_that("brms ignores non-mean random effects", { }) test_that("automatic matching aligns groups and coefficient order", { - marker <- ".dy_member_contrast_assumed_exchangeable_arbitrary" + marker <- ".member_contrast_assumed_exchangeable_arbitrary" blocks <- list( rescov_test_block("coupleID", c("time", "(Intercept)"), "shared"), rescov_test_block( @@ -413,14 +413,33 @@ test_that("automatic matching aligns groups and coefficient order", { } }) +test_that("automatic matching recognizes compact exchangeable columns", { + shared_indicator <- paste0(dyad_retained_prefix, "is_exchangeable") + difference_indicator <- paste0( + dyad_retained_prefix, + "member_contrast_arbitrary" + ) + blocks <- list( + rescov_test_block("coupleID", shared_indicator, "shared"), + rescov_test_block("coupleID", difference_indicator, "difference") + ) + + pair <- match_exchangeable_residual_blocks(blocks)[[1L]] + + expect_equal(pair$shared_block_index, 1L) + expect_equal(pair$difference_block_index, 2L) + expect_equal(pair$shared_indicator, shared_indicator) + expect_equal(pair$difference_indicator, difference_indicator) +}) + test_that("automatic matching handles compositions and grouping levels", { - same_idiff <- ".dy_member_contrast_same_sex_arbitrary" - friend_idiff <- ".dy_member_contrast_friends_arbitrary" + same_idiff <- ".member_contrast_same_sex_arbitrary" + friend_idiff <- ".member_contrast_friends_arbitrary" blocks <- list( rescov_test_block("coupleID", "(Intercept)", "generic"), - rescov_test_block("coupleID", ".dy_is_same_sex", "same shared"), + rescov_test_block("coupleID", ".is_same_sex", "same shared"), rescov_test_block("coupleID", same_idiff, "same difference"), - rescov_test_block("coupleID", ".dy_is_friends", "friend shared"), + rescov_test_block("coupleID", ".is_friends", "friend shared"), rescov_test_block("coupleID", friend_idiff, "friend difference") ) @@ -437,7 +456,7 @@ test_that("automatic matching handles compositions and grouping levels", { ) expect_equal( unlist(lapply(pairs, `[[`, "shared_indicator"), use.names = FALSE), - c(".dy_is_same_sex", ".dy_is_friends") + c(".is_same_sex", ".is_friends") ) repeated <- list( @@ -458,12 +477,18 @@ test_that("automatic matching handles compositions and grouping levels", { }) test_that("automatic matching is conservative about missing and ambiguous blocks", { - marker <- ".dy_member_contrast_assumed_exchangeable_arbitrary" + marker <- ".member_contrast_assumed_exchangeable_arbitrary" + + expect_false( + is_generated_exchangeable_difference_indicator( + ".member_contrast__arbitrary" + ) + ) expect_error( find_exchangeable_difference_indicator(c( - ".dy_member_contrast_friends_arbitrary", - ".dy_member_contrast_coworkers_arbitrary" + ".member_contrast_friends_arbitrary", + ".member_contrast_coworkers_arbitrary" )), "more than one generated difference indicator", fixed = TRUE @@ -639,7 +664,7 @@ test_that("supplied exact pairs align partial and custom-named blocks", { }) test_that("supplied exact pairs support wholly omitted blocks", { - marker <- ".dy_member_contrast_assumed_exchangeable_arbitrary" + marker <- ".member_contrast_assumed_exchangeable_arbitrary" shared_covariance <- rescov_test_covariance(1:2) difference_covariance <- rescov_test_covariance(3:4) blocks <- list( @@ -961,7 +986,7 @@ test_that("omitted blocks are checked without rejecting disjoint pairs", { }) test_that("model-style selectors preserve covariance structures", { - marker <- ".dy_member_contrast_assumed_exchangeable_arbitrary" + marker <- ".member_contrast_assumed_exchangeable_arbitrary" blocks <- list( rescov_test_block( "coupleID", @@ -1078,33 +1103,6 @@ test_that("block pairing names are stable, partial, and unique", { ) }) -test_that("automatic matching recognizes new and legacy member contrasts", { - new_indicator <- ".dy_member_contrast_assumed_exchangeable_arbitrary" - legacy_indicator <- ".dy_diff_assumed_exchangeable_arbitrary" - expect_identical( - find_exchangeable_difference_indicator(new_indicator), - new_indicator - ) - expect_identical( - find_exchangeable_difference_indicator(legacy_indicator), - legacy_indicator - ) - - for (indicator in c(new_indicator, legacy_indicator)) { - blocks <- list( - rescov_test_block("coupleID", "(Intercept)", "(1 | coupleID)"), - rescov_test_block( - "coupleID", - indicator, - paste0("(0 + ", indicator, " | coupleID)") - ) - ) - matched <- match_exchangeable_residual_blocks(blocks) - expect_length(matched, 1L) - expect_identical(matched[[1L]]$difference_indicator, indicator) - } -}) - test_that("supplied pair specifications fail clearly", { blocks <- list( rescov_test_block("coupleID", "(Intercept)", "shared"), @@ -1425,6 +1423,18 @@ test_that("fitted-row validation protects the exchangeable coding", { "IDIFF", "1" )) + short_member_contrast <- paste0( + dyad_retained_prefix, + "member_contrast_arbitrary" + ) + short_coding_data <- data.frame(value = c(-1, 1)) + names(short_coding_data) <- short_member_contrast + expect_no_warning(validate_exchangeable_coding( + short_coding_data, + short_member_contrast, + "1", + group_name = "coupleID" + )) expect_warning( validate_exchangeable_coding( data.frame(other = 1:2), @@ -1521,7 +1531,7 @@ test_that("fitted-row validation protects the exchangeable coding", { fixed = TRUE ) - marker <- ".dy_member_contrast_same_sex_arbitrary" + marker <- ".member_contrast_same_sex_arbitrary" generic_blocks <- list( rescov_test_block("coupleID", "(Intercept)", "generic shared"), rescov_test_block("coupleID", marker, "difference") @@ -1655,7 +1665,7 @@ test_that("residual-level warnings explain brms, omissions, and slopes", { expect_false(grepl("Pair `first`", warnings[[2L]], fixed = TRUE)) mixed_pair <- pair - mixed_pair$shared_indicator <- ".dy_is_same_sex" + mixed_pair$shared_indicator <- ".is_same_sex" expect_warning( warn_about_exchangeable_residual_level( extracted, @@ -1719,7 +1729,7 @@ test_that("residual-level warnings explain brms, omissions, and slopes", { test_that("the public function returns member-level glmmTMB matrices", { skip_if_not_installed("glmmTMB") - marker <- ".dy_member_contrast_assumed_exchangeable_arbitrary" + marker <- ".member_contrast_assumed_exchangeable_arbitrary" data <- expand.grid(member = c(-1, 1), coupleID = seq_len(30)) data$coupleID <- factor(data$coupleID) data[[marker]] <- data$member @@ -1728,7 +1738,7 @@ test_that("the public function returns member-level glmmTMB matrices", { model <- suppressWarnings(glmmTMB::glmmTMB( outcome ~ 1 + (1 | coupleID) + - (0 + .dy_member_contrast_assumed_exchangeable_arbitrary || coupleID), + (0 + .member_contrast_assumed_exchangeable_arbitrary || coupleID), dispformula = ~0, data = data )) diff --git a/tests/testthat/test-center_predictors.R b/tests/testthat/test-center_predictors.R index 5ab4d4d9..2fbdeee6 100644 --- a/tests/testthat/test-center_predictors.R +++ b/tests/testthat/test-center_predictors.R @@ -15,16 +15,16 @@ test_that("center_predictors creates 2l centered predictor columns", { ) |> center_predictors() - expect_true(".dy_x_cwp" %in% names(result)) - expect_true(".dy_x_cbp" %in% names(result)) + expect_true(".x_cwp" %in% names(result)) + expect_true(".x_cbp" %in% names(result)) - expect_equal(result$.dy_x_cwp, c(-1, -1, 1, 1, -1, -1, 1, 1)) - expect_equal(result$.dy_x_cbp, c(-3, -1, -3, -1, 1, 3, 1, 3)) + expect_equal(result$.x_cwp, c(-1, -1, 1, 1, -1, -1, 1, 1)) + expect_equal(result$.x_cbp, c(-3, -1, -3, -1, 1, 3, 1, 3)) person_summary <- dplyr::summarise( dplyr::group_by(result, .data$dyad_id, .data$person_id), - cwp_mean = mean(.data$.dy_x_cwp), - cbp_n = dplyr::n_distinct(.data$.dy_x_cbp), + cwp_mean = mean(.data$.x_cwp), + cbp_n = dplyr::n_distinct(.data$.x_cbp), .groups = "drop" ) @@ -43,7 +43,7 @@ test_that("center_predictors creates 2l centered predictor columns", { tibble::tibble( predictor = c("x", "x", "x"), component = c("raw", "cwp", "cbp"), - column = c("x", ".dy_x_cwp", ".dy_x_cbp"), + column = c("x", ".x_cwp", ".x_cbp"), temporal_decomposition = c("none", "2l", "2l"), lag = c(0L, 0L, 0L) ) @@ -67,8 +67,8 @@ test_that("center_predictors weights people equally for between-person centering ) |> center_predictors() - expect_equal(result$.dy_x_cwp, c(-10, -10, 20, 0, 0, 0)) - expect_equal(result$.dy_x_cbp, c(-22.5, -22.5, -22.5, -12.5, 7.5, 27.5)) + expect_equal(result$.x_cwp, c(-10, -10, 20, 0, 0, 0)) + expect_equal(result$.x_cbp, c(-22.5, -22.5, -22.5, -12.5, 7.5, 27.5)) }) test_that("center_predictors handles missing predictor values", { @@ -88,9 +88,9 @@ test_that("center_predictors handles missing predictor values", { ) |> center_predictors() - expect_equal(result$.dy_x_cwp[1:4], c(0, -1, NA, 1)) - expect_true(all(is.na(result$.dy_x_cwp[5:8]))) - expect_true(all(is.na(result$.dy_x_cbp[5:8]))) + expect_equal(result$.x_cwp[1:4], c(0, -1, NA, 1)) + expect_true(all(is.na(result$.x_cwp[5:8]))) + expect_true(all(is.na(result$.x_cbp[5:8]))) }) test_that("center_predictors does not remove user-owned person mean columns", { @@ -112,8 +112,8 @@ test_that("center_predictors does not remove user-owned person mean columns", { center_predictors() expect_equal(result$x_person_mean, 101:108) - expect_equal(result$.dy_x_cwp, c(-1, -1, 1, 1, -1, -1, 1, 1)) - expect_false(".dy_x_person_mean" %in% names(result)) + expect_equal(result$.x_cwp, c(-1, -1, 1, 1, -1, -1, 1, 1)) + expect_false(".x_person_mean" %in% names(result)) }) test_that("center_predictors leaves uncentered data unchanged", { diff --git a/tests/testthat/test-compare_dyad_models.R b/tests/testthat/test-compare_nested_models.R similarity index 65% rename from tests/testthat/test-compare_dyad_models.R rename to tests/testthat/test-compare_nested_models.R index 6af623a6..44365790 100644 --- a/tests/testthat/test-compare_dyad_models.R +++ b/tests/testthat/test-compare_nested_models.R @@ -1,7 +1,27 @@ comparison_female_male_cross_dyads <- dyads_cross |> dplyr::filter(dyad_composition == "female_x_male") -test_that("compare_nested_glmmTMB_models compares reparameterized nested models", { +test_that("comparison treats unregistered prefixed columns as original data", { + data <- data.frame( + dyad_id = c(1, 1, 2, 2), + person_id = c("A", "B", "C", "D") + ) + prepared <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + seed = 123 + ) + changed <- prepared + changed$.unregistered <- 1 + + expect_error( + validate_comparison_data(NULL, NULL, prepared, changed), + "do not contain the same original columns" + ) +}) + +test_that("compare_nested_models compares reparameterized nested models", { skip_if_not_installed("glmmTMB") full_data <- prepare_dyad_data( @@ -25,36 +45,36 @@ test_that("compare_nested_glmmTMB_models compares reparameterized nested models" full_model <- glmmTMB::glmmTMB( closeness ~ 0 + - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + - .dy_is_female_x_female + - .dy_is_male_x_male + + .is_female_x_male_female + + .is_female_x_male_male + + .is_female_x_female + + .is_male_x_male + us( - 0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | + 0 + .is_female_x_male_female + .is_female_x_male_male | coupleID ) + - us(0 + .dy_is_female_x_female | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID) + - us(0 + .dy_is_male_x_male | coupleID) + - us(0 + .dy_member_contrast_male_x_male_arbitrary | coupleID), + us(0 + .is_female_x_female | coupleID) + + us(0 + .member_contrast_female_x_female_arbitrary | coupleID) + + us(0 + .is_male_x_male | coupleID) + + us(0 + .member_contrast_male_x_male_arbitrary | coupleID), dispformula = ~0, family = gaussian(), data = full_data ) restricted_model <- glmmTMB::glmmTMB( closeness ~ 0 + - .dy_is_female_x_female + - .dy_is_non_female_x_female + - us(0 + .dy_is_female_x_female | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID) + - us(0 + .dy_is_non_female_x_female | coupleID) + - us(0 + .dy_member_contrast_non_female_x_female_arbitrary | coupleID), + .is_female_x_female + + .is_non_female_x_female + + us(0 + .is_female_x_female | coupleID) + + us(0 + .member_contrast_female_x_female_arbitrary | coupleID) + + us(0 + .is_non_female_x_female | coupleID) + + us(0 + .member_contrast_non_female_x_female_arbitrary | coupleID), dispformula = ~0, family = gaussian(), data = restricted_data ) - comparison <- compare_nested_glmmTMB_models(restricted_model, full_model) + comparison <- compare_nested_models(restricted_model, full_model) expect_s3_class(comparison, "anova") expect_equal(comparison$`Chi Df`[2], 5) @@ -65,7 +85,83 @@ test_that("compare_nested_glmmTMB_models compares reparameterized nested models" expect_lt(comparison$`Pr(>Chisq)`[2], 0.001) }) -test_that("compare_nested_glmmTMB_models requires exact original data", { +test_that("one prepared object supports both distinguishability models", { + skip_if_not_installed("glmmTMB") + + comparison_data <- prepare_dyad_data( + comparison_female_male_cross_dyads, + dyad = coupleID, + member = personID, + role = gender, + predictors = provided_support, + include_arbitrary_member_contrast = TRUE, + seed = 123 + ) + exchangeable_data <- prepare_dyad_data( + comparison_female_male_cross_dyads, + dyad = coupleID, + member = personID, + role = gender, + predictors = provided_support, + set_exchangeable_compositions = "female-male", + seed = 123 + ) + + full_model <- glmmTMB::glmmTMB( + closeness ~ 0 + + .is_female + + .is_male + + .is_female:.provided_support_actor + + .is_male:.provided_support_actor + + .is_female:.provided_support_partner + + .is_male:.provided_support_partner + + us(0 + .is_female + .is_male | coupleID), + dispformula = ~0, + family = gaussian(), + data = comparison_data + ) + restricted_model <- glmmTMB::glmmTMB( + closeness ~ + .provided_support_actor + + .provided_support_partner + + us(1 | coupleID) + + us(0 + .member_contrast_arbitrary | coupleID), + dispformula = ~0, + family = gaussian(), + data = comparison_data + ) + re_prepared_model <- update( + restricted_model, + data = exchangeable_data + ) + + comparison <- compare_nested_models( + restricted_model, + full_model + ) + recovered <- recover_exchangeable_covariance(restricted_model) + + expect_s3_class(comparison, "anova") + expect_equal(comparison$`Chi Df`[2], 4) + expect_s3_class(recovered, "exchangeable_rescov") + expect_equal( + as.numeric(stats::logLik(restricted_model)), + as.numeric(stats::logLik(re_prepared_model)), + tolerance = 1e-8 + ) + expect_equal( + glmmTMB::fixef(restricted_model), + glmmTMB::fixef(re_prepared_model), + tolerance = 1e-8 + ) + expect_equal( + glmmTMB::VarCorr(restricted_model), + glmmTMB::VarCorr(re_prepared_model), + tolerance = 1e-8 + ) +}) + +test_that("compare_nested_models requires exact original data", { skip_if_not_installed("glmmTMB") data_one <- prepare_dyad_data( @@ -93,7 +189,7 @@ test_that("compare_nested_glmmTMB_models requires exact original data", { ) expect_error( - compare_nested_glmmTMB_models(model_one, model_two), + compare_nested_models(model_one, model_two), "Column `closeness` differs" ) @@ -110,7 +206,7 @@ test_that("compare_nested_glmmTMB_models requires exact original data", { ) }) -test_that("compare_nested_glmmTMB_models checks source and fitted rows", { +test_that("compare_nested_models checks source and fitted rows", { skip_if_not_installed("glmmTMB") complete_data <- prepare_dyad_data( @@ -157,16 +253,16 @@ test_that("compare_nested_glmmTMB_models checks source and fitted rows", { ) expect_error( - compare_nested_glmmTMB_models(complete_restricted, shorter_full), + compare_nested_models(complete_restricted, shorter_full), "different numbers of rows" ) expect_error( - compare_nested_glmmTMB_models(row_restricted, row_full), + compare_nested_models(row_restricted, row_full), "different observation rows" ) }) -test_that("compare_nested_glmmTMB_models supports and checks model families", { +test_that("compare_nested_models supports and checks model families", { skip_if_not_installed("glmmTMB") data <- comparison_female_male_cross_dyads @@ -202,7 +298,7 @@ test_that("compare_nested_glmmTMB_models supports and checks model families", { data = full_data ) - comparison <- compare_nested_glmmTMB_models(restricted_model, full_model) + comparison <- compare_nested_models(restricted_model, full_model) expect_s3_class(comparison, "anova") expect_equal(comparison$`Chi Df`[2], 1) @@ -211,12 +307,12 @@ test_that("compare_nested_glmmTMB_models supports and checks model families", { 2 * as.numeric(logLik(full_model) - logLik(restricted_model)) ) expect_error( - compare_nested_glmmTMB_models(restricted_model, gaussian_model), + compare_nested_models(restricted_model, gaussian_model), "same family and link" ) }) -test_that("compare_nested_glmmTMB_models compares APIM, DIM, and DSM models", { +test_that("compare_nested_models compares APIM, DIM, and DSM models", { skip_if_not_installed("glmmTMB") distinguishable_data <- prepare_dyad_data( @@ -226,7 +322,8 @@ test_that("compare_nested_glmmTMB_models compares APIM, DIM, and DSM models", { role = gender, predictors = provided_support, model_types = c("apim", "dsm"), - dsm_role_order = c("female", "male") + dsm_role_order = c("female", "male"), + short_colnames = FALSE ) exchangeable_data <- prepare_dyad_data( comparison_female_male_cross_dyads, @@ -236,41 +333,42 @@ test_that("compare_nested_glmmTMB_models compares APIM, DIM, and DSM models", { predictors = provided_support, model_types = c("apim", "dim"), set_exchangeable_compositions = "female-male", + short_colnames = FALSE, seed = 123 ) distinguishable_dsm <- glmmTMB::glmmTMB( closeness ~ 1 + - .dy_provided_support_dyad_mean_gmc + - .dy_provided_support_within_dyad_diff + - .dy_dsm_role_contrast + - .dy_provided_support_dyad_mean_gmc:.dy_dsm_role_contrast + - .dy_provided_support_within_dyad_diff:.dy_dsm_role_contrast + - us(1 + .dy_dsm_role_contrast | coupleID), + .provided_support_dyad_mean_gmc + + .provided_support_within_dyad_diff + + .dsm_role_contrast + + .provided_support_dyad_mean_gmc:.dsm_role_contrast + + .provided_support_within_dyad_diff:.dsm_role_contrast + + us(1 + .dsm_role_contrast | coupleID), dispformula = ~0, family = gaussian(), data = distinguishable_data ) exchangeable_apim <- glmmTMB::glmmTMB( - closeness ~ 0 + .dy_is_female_x_male + - .dy_provided_support_actor + - .dy_provided_support_partner + - us(0 + .dy_is_female_x_male | coupleID) + - us(0 + .dy_member_contrast_female_x_male_arbitrary | coupleID), + closeness ~ 0 + .is_female_x_male + + .provided_support_actor + + .provided_support_partner + + us(0 + .is_female_x_male | coupleID) + + us(0 + .member_contrast_female_x_male_arbitrary | coupleID), dispformula = ~0, family = gaussian(), data = exchangeable_data ) distinguishable_apim <- glmmTMB::glmmTMB( closeness ~ 0 + - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + - .dy_is_female_x_male_female:.dy_provided_support_actor + - .dy_is_female_x_male_male:.dy_provided_support_actor + - .dy_is_female_x_male_female:.dy_provided_support_partner + - .dy_is_female_x_male_male:.dy_provided_support_partner + + .is_female_x_male_female + + .is_female_x_male_male + + .is_female_x_male_female:.provided_support_actor + + .is_female_x_male_male:.provided_support_actor + + .is_female_x_male_female:.provided_support_partner + + .is_female_x_male_male:.provided_support_partner + us( - 0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | + 0 + .is_female_x_male_female + .is_female_x_male_male | coupleID ), dispformula = ~0, @@ -279,20 +377,20 @@ test_that("compare_nested_glmmTMB_models compares APIM, DIM, and DSM models", { ) exchangeable_dim <- glmmTMB::glmmTMB( closeness ~ 1 + - .dy_provided_support_dyad_mean_gmc + - .dy_provided_support_within_dyad_dev + + .provided_support_dyad_mean_gmc + + .provided_support_within_dyad_dev + us(1 | coupleID) + - us(0 + .dy_member_contrast_female_x_male_arbitrary | coupleID), + us(0 + .member_contrast_female_x_male_arbitrary | coupleID), dispformula = ~0, family = gaussian(), data = exchangeable_data ) - dsm_comparison <- compare_nested_glmmTMB_models( + dsm_comparison <- compare_nested_models( distinguishable_dsm, exchangeable_apim ) - apim_dim_comparison <- compare_nested_glmmTMB_models( + apim_dim_comparison <- compare_nested_models( distinguishable_apim, exchangeable_dim ) @@ -302,7 +400,7 @@ test_that("compare_nested_glmmTMB_models compares APIM, DIM, and DSM models", { expect_equal(dsm_comparison$Chisq[2], apim_dim_comparison$Chisq[2]) }) -test_that("compare_nested_glmmTMB_models supports ordinary and mixed named data", { +test_that("compare_nested_models supports ordinary and mixed named data", { skip_if_not_installed("glmmTMB") plain_data_one <- comparison_female_male_cross_dyads @@ -337,8 +435,8 @@ test_that("compare_nested_glmmTMB_models supports ordinary and mixed named data" data = as.data.frame(plain_data_one) ) - plain_comparison <- compare_nested_glmmTMB_models(plain_smaller, plain_larger) - mixed_comparison <- compare_nested_glmmTMB_models(plain_smaller, prepared_larger) + plain_comparison <- compare_nested_models(plain_smaller, plain_larger) + mixed_comparison <- compare_nested_models(plain_smaller, prepared_larger) expect_equal(plain_comparison$`Chi Df`[2], 1) expect_equal( @@ -350,11 +448,11 @@ test_that("compare_nested_glmmTMB_models supports ordinary and mixed named data" plain_comparison$Chisq[2] ) expect_error( - compare_nested_glmmTMB_models(plain_smaller, changed_model), + compare_nested_models(plain_smaller, changed_model), "Column `provided_support` differs" ) expect_error( - compare_nested_glmmTMB_models(inline_model, plain_larger), + compare_nested_models(inline_model, plain_larger), "must have been fitted with a named data frame" ) @@ -371,7 +469,7 @@ test_that("compare_nested_glmmTMB_models supports ordinary and mixed named data" ) }) -test_that("compare_nested_glmmTMB_models sorts models and agrees with anova.glmmTMB", { +test_that("compare_nested_models sorts models and agrees with anova.glmmTMB", { skip_if_not_installed("glmmTMB") model_data <- prepare_dyad_data( @@ -390,8 +488,8 @@ test_that("compare_nested_glmmTMB_models sorts models and agrees with anova.glmm ) reference <- stats::anova(restricted_model, full_model) - comparison <- compare_nested_glmmTMB_models(restricted_model, full_model) - reversed <- compare_nested_glmmTMB_models(full_model, restricted_model) + comparison <- compare_nested_models(restricted_model, full_model) + reversed <- compare_nested_models(full_model, restricted_model) expect_equal(comparison$Chisq[2], reference$Chisq[2]) expect_equal(comparison$`Chi Df`[2], reference$`Chi Df`[2]) @@ -403,7 +501,7 @@ test_that("compare_nested_glmmTMB_models sorts models and agrees with anova.glmm reference$`Pr(>Chisq)`[2] < 0.05 ) expect_error( - compare_nested_glmmTMB_models(restricted_model, restricted_model), + compare_nested_models(restricted_model, restricted_model), "different numbers of estimated parameters" ) @@ -441,7 +539,7 @@ test_that("compare_nested_glmmTMB_models sorts models and agrees with anova.glmm model_data$noise <- stats::rnorm(nrow(model_data)) smaller_model <- glmmTMB::glmmTMB(closeness ~ 1, data = model_data) larger_model <- glmmTMB::glmmTMB(closeness ~ noise, data = model_data) - no_clear_improvement <- compare_nested_glmmTMB_models(smaller_model, larger_model) + no_clear_improvement <- compare_nested_models(smaller_model, larger_model) printed <- capture.output(print(no_clear_improvement)) expect_gt(no_clear_improvement$`Pr(>Chisq)`[2], 0.05) @@ -471,7 +569,7 @@ test_that("compare_nested_glmmTMB_models sorts models and agrees with anova.glmm ) }) -test_that("compare_nested_glmmTMB_models rejects transformed and changed outcomes", { +test_that("compare_nested_models rejects transformed and changed outcomes", { skip_if_not_installed("glmmTMB") model_data <- prepare_dyad_data( @@ -496,11 +594,11 @@ test_that("compare_nested_glmmTMB_models rejects transformed and changed outcome ) expect_error( - compare_nested_glmmTMB_models(restricted_model, transformed_model), + compare_nested_models(restricted_model, transformed_model), "Only an untransformed outcome" ) expect_error( - compare_nested_glmmTMB_models(restricted_model, alternate_outcome_model), + compare_nested_models(restricted_model, alternate_outcome_model), "use different outcome variables" ) @@ -510,12 +608,12 @@ test_that("compare_nested_glmmTMB_models rejects transformed and changed outcome data = model_data ) expect_error( - compare_nested_glmmTMB_models(restricted_model, changed_model), + compare_nested_models(restricted_model, changed_model), "fitted outcome values differ" ) }) -test_that("compare_nested_glmmTMB_models recovers local model data", { +test_that("compare_nested_models recovers local model data", { skip_if_not_installed("glmmTMB") fit_models <- function() { @@ -532,40 +630,40 @@ test_that("compare_nested_glmmTMB_models recovers local model data", { } models <- fit_models() - comparison <- compare_nested_glmmTMB_models(models$restricted, models$full) + comparison <- compare_nested_models(models$restricted, models$full) expect_s3_class(comparison, "anova") }) -test_that("compare_nested_glmmTMB_models rejects unsuitable fitted models", { +test_that("compare_nested_models rejects unsuitable fitted models", { skip_if_not_installed("glmmTMB") model_data <- comparison_female_male_cross_dyads valid_model <- glmmTMB::glmmTMB(closeness ~ 1, data = model_data) expect_error( - compare_nested_glmmTMB_models(stats::lm(closeness ~ 1, data = model_data), valid_model), + compare_nested_models(stats::lm(closeness ~ 1, data = model_data), valid_model), "`model1` must be a fitted `glmmTMB` model" ) reml_model <- valid_model reml_model$modelInfo$REML <- TRUE expect_error( - compare_nested_glmmTMB_models(valid_model, reml_model), + compare_nested_models(valid_model, reml_model), "`model2` model was fitted with REML" ) unconverged_model <- valid_model unconverged_model$fit$convergence <- 1L expect_error( - compare_nested_glmmTMB_models(valid_model, unconverged_model), + compare_nested_models(valid_model, unconverged_model), "`model2` model did not converge" ) indefinite_hessian_model <- valid_model indefinite_hessian_model$sdr$pdHess <- FALSE expect_error( - compare_nested_glmmTMB_models(valid_model, indefinite_hessian_model), + compare_nested_models(valid_model, indefinite_hessian_model), "`model2` model has a non-positive-definite Hessian matrix" ) @@ -581,7 +679,7 @@ test_that("compare_nested_glmmTMB_models rejects unsuitable fitted models", { ) }) -test_that("compare_nested_glmmTMB_models checks weights and offsets", { +test_that("compare_nested_models checks weights and offsets", { skip_if_not_installed("glmmTMB") data <- comparison_female_male_cross_dyads @@ -615,15 +713,15 @@ test_that("compare_nested_glmmTMB_models checks weights and offsets", { ) expect_error( - compare_nested_glmmTMB_models(full_model, weighted_model), + compare_nested_models(full_model, weighted_model), "different observation weights" ) expect_error( - compare_nested_glmmTMB_models(full_model, offset_model), + compare_nested_models(full_model, offset_model), "different offsets" ) expect_error( - compare_nested_glmmTMB_models(offset_model, zero_inflation_offset_model), + compare_nested_models(offset_model, zero_inflation_offset_model), "different offsets" ) }) diff --git a/tests/testthat/test-dyad_generated_columns.R b/tests/testthat/test-dyad_generated_columns.R index 047711f8..0236160c 100644 --- a/tests/testthat/test-dyad_generated_columns.R +++ b/tests/testthat/test-dyad_generated_columns.R @@ -1,3 +1,9 @@ +non_composition_generated_columns <- function(prepared) { + dyad_generated_columns(attr(prepared, "dyadMLM")) |> + dplyr::filter(.data$model_family != "composition") |> + dplyr::select(-"short_column_pattern") +} + test_that("dyad_generated_columns returns empty metadata without model columns", { result <- dyad_generated_columns(list()) @@ -6,13 +12,15 @@ test_that("dyad_generated_columns returns empty metadata without model columns", test_that("dyad_generated_columns errors when generated column specs are missing", { meta <- list( - apim_predictors = tibble::tibble( - predictor = "x", + generated_columns = tibble::tibble( + model_family = "apim", + variable_role = "predictor", + variable = "x", component = "unsupported", lag = 0L, - source_column = "x", - actor_column = ".dy_x_unsupported_actor", - partner_column = ".dy_x_unsupported_partner" + column_role = "actor", + column = ".x_unsupported_actor", + source_column = "x" ) ) @@ -22,6 +30,131 @@ test_that("dyad_generated_columns errors when generated column specs are missing ) }) +test_that("generated column specification keys are unique", { + specifications <- generated_column_spec_lookup() + keys <- c("model_family", "variable_role", "component", "column_role") + + expect_equal(anyDuplicated(specifications[keys]), 0L) +}) + +test_that("dyad_generated_columns records every created composition column", { + data <- data.frame( + dyad_id = c(1, 1, 2, 2), + person_id = c("A", "B", "C", "D"), + role = c("female", "male", "female", "male") + ) + + prepared <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + role = role, + model_types = "none" + ) + + meta <- attr(prepared, "dyadMLM") + stored <- meta$generated_columns + result <- dyad_generated_columns(meta) + + expect_equal(stored, result[names(stored)]) + expect_setequal(stored$column, setdiff(names(prepared), names(data))) + expect_true(all(result$model_family == "composition")) + expect_false(any(grepl("member_contrast", result$column, fixed = TRUE))) +}) + +test_that("dyad_generated_columns records exchangeable member contrasts", { + data <- data.frame( + dyad_id = c(1, 1, 2, 2), + person_id = c("A", "B", "C", "D") + ) + + prepared <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + model_types = "none", + seed = 123 + ) + + result <- dyad_generated_columns(attr(prepared, "dyadMLM")) + short_composition_indicator <- paste0( + dyad_retained_prefix, + "is_exchangeable" + ) + short_member_contrast <- paste0( + dyad_retained_prefix, + "member_contrast_arbitrary" + ) + + composition_columns <- result |> + dplyr::arrange(.data$print_order) |> + dplyr::select("column_role", "column", "print_order") + expect_equal( + composition_columns, + tibble::tibble( + column_role = c( + "composition", + "composition_role", + "composition_indicator", + "member_contrast" + ), + column = c( + ".composition", + ".composition_role", + short_composition_indicator, + short_member_contrast + ), + print_order = 1:4 + ) + ) + + member_contrast <- result |> + dplyr::filter(.data$column_role == "member_contrast") |> + dplyr::select( + "model_family", "variable_role", "component", "lag", + "source_column", "temporal_decomposition", "dyadic_decomposition", + "column_centering", "print_order", "column_pattern", + "short_column_pattern" + ) + expect_equal( + member_contrast, + tibble::tibble( + model_family = "composition", + variable_role = "composition", + component = "none", + lag = 0L, + source_column = ".composition", + temporal_decomposition = "none", + dyadic_decomposition = "none", + column_centering = "none", + print_order = 4L, + column_pattern = short_member_contrast, + short_column_pattern = short_member_contrast + ) + ) + + long_prepared <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + model_types = "none", + short_colnames = FALSE, + seed = 123 + ) + long_result <- dyad_generated_columns(attr(long_prepared, "dyadMLM")) + + expect_equal( + long_result$column[long_result$column_role == "member_contrast"], + ".member_contrast_assumed_exchangeable_arbitrary" + ) + expect_equal( + long_result$column_pattern[ + long_result$column_role == "member_contrast" + ], + ".member_contrast_{comp}_arbitrary" + ) +}) + test_that("dyad_generated_columns collects APIM columns", { data <- data.frame( dyad_id = c(1, 1, 2, 2), @@ -38,7 +171,7 @@ test_that("dyad_generated_columns collects APIM columns", { seed = 123 ) - result <- dyad_generated_columns(attr(prepared, "dyadMLM")) + result <- non_composition_generated_columns(prepared) expect_equal( result, @@ -49,13 +182,13 @@ test_that("dyad_generated_columns collects APIM columns", { component = c("raw", "raw"), lag = c(0L, 0L), column_role = c("actor", "partner"), - column = c(".dy_x_actor", ".dy_x_partner"), + column = c(".x_actor", ".x_partner"), source_column = c("x", "x"), temporal_decomposition = c("none", "none"), dyadic_decomposition = c("none", "none"), column_centering = c("none", "none"), print_order = c(10L, 11L), - column_pattern = c(".dy_{pred}_actor", ".dy_{pred}_partner"), + column_pattern = c(".{pred}_actor", ".{pred}_partner"), description = c( "APIM actor predictor: actor's original predictor values", "APIM partner predictor: partner's original predictor values" @@ -81,7 +214,7 @@ test_that("dyad_generated_columns excludes raw temporal predictor records", { seed = 123 ) - result <- dyad_generated_columns(attr(prepared, "dyadMLM")) + result <- non_composition_generated_columns(prepared) expect_equal(nrow(result), 0) }) @@ -103,7 +236,7 @@ test_that("dyad_generated_columns records temporal decomposition for APIM column seed = 123 ) - result <- dyad_generated_columns(attr(prepared, "dyadMLM")) + result <- non_composition_generated_columns(prepared) expect_equal( result, @@ -124,16 +257,16 @@ test_that("dyad_generated_columns records temporal decomposition for APIM column "partner" ), column = c( - ".dy_x_cwp", - ".dy_x_cbp", - ".dy_x_actor", - ".dy_x_cwp_actor", - ".dy_x_cbp_actor", - ".dy_x_partner", - ".dy_x_cwp_partner", - ".dy_x_cbp_partner" + ".x_cwp", + ".x_cbp", + ".x_actor", + ".x_cwp_actor", + ".x_cbp_actor", + ".x_partner", + ".x_cwp_partner", + ".x_cbp_partner" ), - source_column = c("x", "x", "x", ".dy_x_cwp", ".dy_x_cbp", "x", ".dy_x_cwp", ".dy_x_cbp"), + source_column = c("x", "x", "x", ".x_cwp", ".x_cbp", "x", ".x_cwp", ".x_cbp"), temporal_decomposition = c( "within_person", "between_person_grand_mean", @@ -148,14 +281,14 @@ test_that("dyad_generated_columns records temporal decomposition for APIM column column_centering = rep("none", 8), print_order = c(8L, 9L, 10L, 12L, 14L, 11L, 13L, 15L), column_pattern = c( - ".dy_{pred}_cwp", - ".dy_{pred}_cbp", - ".dy_{pred}_actor", - ".dy_{pred}_cwp_actor", - ".dy_{pred}_cbp_actor", - ".dy_{pred}_partner", - ".dy_{pred}_cwp_partner", - ".dy_{pred}_cbp_partner" + ".{pred}_cwp", + ".{pred}_cbp", + ".{pred}_actor", + ".{pred}_cwp_actor", + ".{pred}_cbp_actor", + ".{pred}_partner", + ".{pred}_cwp_partner", + ".{pred}_cbp_partner" ), description = c( "within-person predictor: momentary deviations from each person's usual level", @@ -188,7 +321,7 @@ test_that("dyad_generated_columns collects DIM columns", { seed = 123 ) - result <- dyad_generated_columns(attr(prepared, "dyadMLM")) + result <- non_composition_generated_columns(prepared) expect_equal( result, @@ -199,13 +332,13 @@ test_that("dyad_generated_columns collects DIM columns", { component = c("raw", "raw"), lag = c(0L, 0L), column_role = c("dyad_mean", "within_dyad_deviation"), - column = c(".dy_x_dyad_mean_gmc", ".dy_x_within_dyad_dev"), + column = c(".x_dyad_mean_gmc", ".x_within_dyad_dev"), source_column = c("x", "x"), temporal_decomposition = c("none", "none"), dyadic_decomposition = c("dyad_mean", "within_dyad_deviation"), column_centering = c("grand_mean", "none"), print_order = c(20L, 21L), - column_pattern = c(".dy_{pred}_dyad_mean_gmc", ".dy_{pred}_within_dyad_dev"), + column_pattern = c(".{pred}_dyad_mean_gmc", ".{pred}_within_dyad_dev"), description = c( "dyad-mean predictor: dyad's average predictor level, grand-mean centered", "DIM within-dyad member-deviation predictor: member's difference from the dyad mean" @@ -232,7 +365,7 @@ test_that("dyad_generated_columns records temporal and dyadic decomposition for seed = 123 ) - result <- dyad_generated_columns(attr(prepared, "dyadMLM")) + result <- non_composition_generated_columns(prepared) expect_equal( result$temporal_decomposition, @@ -291,7 +424,7 @@ test_that("dyad_generated_columns combines requested model families", { seed = 123 ) - result <- dyad_generated_columns(attr(prepared, "dyadMLM")) + result <- non_composition_generated_columns(prepared) expect_equal( result$model_family, @@ -323,7 +456,7 @@ test_that("dyad_generated_columns collects DSM columns", { seed = 123 ) - result <- dyad_generated_columns(attr(prepared, "dyadMLM")) + result <- non_composition_generated_columns(prepared) expect_equal( result$model_family, @@ -340,9 +473,9 @@ test_that("dyad_generated_columns collects DSM columns", { expect_equal( result$column, c( - ".dy_dsm_role_contrast", - ".dy_x_dyad_mean_gmc", - ".dy_x_within_dyad_diff" + ".dsm_role_contrast", + ".x_dyad_mean_gmc", + ".x_within_dyad_diff" ) ) expect_equal(result$dyadic_decomposition, c("role_contrast", "dyad_mean", "dyad_difference")) diff --git a/tests/testthat/test-example-data.R b/tests/testthat/test-example-data.R index 699a950b..cd347a8a 100644 --- a/tests/testthat/test-example-data.R +++ b/tests/testthat/test-example-data.R @@ -66,18 +66,18 @@ check_example_dyads <- function( expect_equal(dyad_compositions$n_dyads, c(120L, 120L, 120L)) expect_false(dyad_diff_col %in% names(prepared)) expect_true( - ".dy_member_contrast_female_x_female_arbitrary" %in% names(prepared) + ".member_contrast_female_x_female_arbitrary" %in% names(prepared) ) expect_true( - ".dy_member_contrast_male_x_male_arbitrary" %in% names(prepared) + ".member_contrast_male_x_male_arbitrary" %in% names(prepared) ) - female_female <- prepared$.dy_composition == "female_x_female" - male_male <- prepared$.dy_composition == "male_x_male" + female_female <- prepared$.composition == "female_x_female" + male_male <- prepared$.composition == "male_x_male" female_female_contrast <- - prepared$.dy_member_contrast_female_x_female_arbitrary + prepared$.member_contrast_female_x_female_arbitrary male_male_contrast <- - prepared$.dy_member_contrast_male_x_male_arbitrary + prepared$.member_contrast_male_x_male_arbitrary expect_true(all(abs(female_female_contrast[female_female]) == 1)) expect_true(all(female_female_contrast[!female_female] == 0)) diff --git a/tests/testthat/test-infer_dyad_compositions.R b/tests/testthat/test-infer_dyad_compositions.R index a761a0da..d3fedf1e 100644 --- a/tests/testthat/test-infer_dyad_compositions.R +++ b/tests/testthat/test-infer_dyad_compositions.R @@ -16,24 +16,24 @@ test_that("infer_dyad_compositions counts role compositions", { expect_s3_class(result, "dyadMLM_data") expect_false(".dy_raw_composition" %in% names(result)) expect_false(".dy_arbitrary_role" %in% names(result)) - expect_true(".dy_composition" %in% names(result)) - expect_true(".dy_composition_role" %in% names(result)) - expect_true(is.factor(result$.dy_composition)) - expect_true(is.factor(result$.dy_composition_role)) - indicator_names <- grep("^\\.dy_is_", names(result), value = TRUE) + expect_true(".composition" %in% names(result)) + expect_true(".composition_role" %in% names(result)) + expect_true(is.factor(result$.composition)) + expect_true(is.factor(result$.composition_role)) + indicator_names <- grep("^\\.is_", names(result), value = TRUE) expect_equal( indicator_names, c( - ".dy_is_female_x_female", - ".dy_is_female_x_male_female", - ".dy_is_female_x_male_male", - ".dy_is_male_x_male" + ".is_female_x_female", + ".is_female_x_male_female", + ".is_female_x_male_male", + ".is_male_x_male" ) ) - expect_true(".dy_member_contrast_female_x_female_arbitrary" %in% names(result)) - expect_true(".dy_member_contrast_male_x_male_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_female_x_female" %in% names(result)) - expect_false(".dy_member_contrast_male_x_male" %in% names(result)) + expect_true(".member_contrast_female_x_female_arbitrary" %in% names(result)) + expect_true(".member_contrast_male_x_male_arbitrary" %in% names(result)) + expect_false(".member_contrast_female_x_female" %in% names(result)) + expect_false(".member_contrast_male_x_male" %in% names(result)) expect_true(all(sapply(result[indicator_names], is.numeric))) expect_equal(rowSums(result[indicator_names]), rep(1, nrow(result))) @@ -58,22 +58,22 @@ test_that("infer_dyad_compositions counts role compositions", { ) expect_equal(dyad_compositions$n_dyads, c(1L, 2L, 1L)) expect_equal( - as.character(result$.dy_composition), + as.character(result$.composition), c("female_x_male", "female_x_male", "female_x_male", "female_x_male", "female_x_female", "female_x_female", "male_x_male", "male_x_male") ) expect_equal( - as.character(result$.dy_composition_role), + as.character(result$.composition_role), c("female_x_male_female", "female_x_male_male", "female_x_male_female", "female_x_male_male", "female_x_female", "female_x_female", "male_x_male", "male_x_male") ) expect_false(dyad_diff_col %in% names(result)) - expect_equal(abs(result$.dy_member_contrast_female_x_female_arbitrary[result$dyad_id == 3]), rep(1, 2)) - expect_equal(abs(result$.dy_member_contrast_male_x_male_arbitrary[result$dyad_id == 4]), rep(1, 2)) - expect_equal(result$.dy_member_contrast_female_x_female_arbitrary[result$dyad_id != 3], rep(0, 6)) - expect_equal(result$.dy_member_contrast_male_x_male_arbitrary[result$dyad_id != 4], rep(0, 6)) + expect_equal(abs(result$.member_contrast_female_x_female_arbitrary[result$dyad_id == 3]), rep(1, 2)) + expect_equal(abs(result$.member_contrast_male_x_male_arbitrary[result$dyad_id == 4]), rep(1, 2)) + expect_equal(result$.member_contrast_female_x_female_arbitrary[result$dyad_id != 3], rep(0, 6)) + expect_equal(result$.member_contrast_male_x_male_arbitrary[result$dyad_id != 4], rep(0, 6)) }) test_that("composition-specific diff signs do not depend on distinguishable dyads", { @@ -107,13 +107,48 @@ test_that("composition-specific diff signs do not depend on distinguishable dyad ) |> infer_dyad_compositions(seed = 123) + mixed_result_with_distinguishable_contrast <- validate_dyad_data( + mixed, + dyad = dyad_id, + member = person_id, + role = role + ) |> + infer_dyad_compositions( + seed = 123, + include_arbitrary_member_contrast = TRUE + ) + + expect_equal( + mixed_result$.member_contrast_female_x_female_arbitrary[mixed_result$dyad_id == 2], + exchangeable_result$.member_contrast_female_x_female_arbitrary[exchangeable_result$dyad_id == 2] + ) + expect_equal( + mixed_result$.member_contrast_male_x_male_arbitrary[mixed_result$dyad_id == 3], + exchangeable_result$.member_contrast_male_x_male_arbitrary[exchangeable_result$dyad_id == 3] + ) + expect_equal( + mixed_result_with_distinguishable_contrast$.member_contrast_female_x_female_arbitrary, + mixed_result$.member_contrast_female_x_female_arbitrary + ) expect_equal( - mixed_result$.dy_member_contrast_female_x_female_arbitrary[mixed_result$dyad_id == 2], - exchangeable_result$.dy_member_contrast_female_x_female_arbitrary[exchangeable_result$dyad_id == 2] + mixed_result_with_distinguishable_contrast$.member_contrast_male_x_male_arbitrary, + mixed_result$.member_contrast_male_x_male_arbitrary ) expect_equal( - mixed_result$.dy_member_contrast_male_x_male_arbitrary[mixed_result$dyad_id == 3], - exchangeable_result$.dy_member_contrast_male_x_male_arbitrary[exchangeable_result$dyad_id == 3] + sort(mixed_result_with_distinguishable_contrast$.member_contrast_female_x_male_arbitrary[ + mixed_result_with_distinguishable_contrast$dyad_id == 1 + ]), + c(-1, 1) + ) + expect_equal( + mixed_result_with_distinguishable_contrast$.member_contrast_female_x_male_arbitrary[ + mixed_result_with_distinguishable_contrast$dyad_id != 1 + ], + rep(0, 4) + ) + expect_equal( + attr(mixed_result_with_distinguishable_contrast, "dyadMLM")$dyad_compositions, + attr(mixed_result, "dyadMLM")$dyad_compositions ) }) @@ -137,14 +172,20 @@ test_that("infer_dyad_compositions can set distinguishable compositions exchange set_exchangeable_compositions = "male-female" ) - expect_true(".dy_is_female_x_male" %in% names(result)) - expect_false(".dy_is_female_x_male_female" %in% names(result)) - expect_false(".dy_is_female_x_male_male" %in% names(result)) - expect_true(".dy_member_contrast_female_x_male_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_female_x_male" %in% names(result)) - expect_equal(abs(result$.dy_member_contrast_female_x_male_arbitrary), rep(1, 4)) - expect_equal(as.character(result$.dy_composition), rep("female_x_male", 4)) - expect_equal(as.character(result$.dy_composition_role), rep("female_x_male", 4)) + exchangeable_indicator <- paste0(dyad_retained_prefix, "is_exchangeable") + short_member_contrast <- paste0( + dyad_retained_prefix, + "member_contrast_arbitrary" + ) + + expect_true(exchangeable_indicator %in% names(result)) + expect_false(".is_female_x_male_female" %in% names(result)) + expect_false(".is_female_x_male_male" %in% names(result)) + expect_true(short_member_contrast %in% names(result)) + expect_false(".member_contrast_female_x_male" %in% names(result)) + expect_equal(abs(result[[short_member_contrast]]), rep(1, 4)) + expect_equal(as.character(result$.composition), rep("female_x_male", 4)) + expect_equal(as.character(result$.composition_role), rep("female_x_male", 4)) expect_equal( attr(result, "dyadMLM")$dyad_compositions, tibble::tibble( @@ -246,13 +287,15 @@ test_that("infer_dyad_compositions pools exchangeable compositions", { pool_compositions = list(same_sex = c("female-female", "male male")) ) - expect_true(".dy_is_same_sex" %in% names(result)) - expect_true(".dy_member_contrast_same_sex_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_same_sex" %in% names(result)) - expect_false(".dy_member_contrast_female_x_female_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_male_x_male_arbitrary" %in% names(result)) - expect_equal(as.character(result$.dy_composition), rep("same_sex", 4)) - expect_equal(as.character(result$.dy_composition_role), rep("same_sex", 4)) + expect_true(paste0(dyad_retained_prefix, "is_exchangeable") %in% names(result)) + expect_true( + paste0(dyad_retained_prefix, "member_contrast_arbitrary") %in% names(result) + ) + expect_false(".member_contrast_same_sex" %in% names(result)) + expect_false(".member_contrast_female_x_female_arbitrary" %in% names(result)) + expect_false(".member_contrast_male_x_male_arbitrary" %in% names(result)) + expect_equal(as.character(result$.composition), rep("same_sex", 4)) + expect_equal(as.character(result$.composition_role), rep("same_sex", 4)) expect_equal( attr(result, "dyadMLM")$dyad_compositions, @@ -266,7 +309,7 @@ test_that("infer_dyad_compositions pools exchangeable compositions", { ) }) -test_that("role-aware pools named assumed_exchangeable retain composition-specific naming", { +test_that("compact names do not depend on a pooled composition label", { data <- data.frame( dyad_id = c(1, 1, 2, 2), person_id = c("A", "B", "C", "D"), @@ -286,10 +329,17 @@ test_that("role-aware pools named assumed_exchangeable retain composition-specif ) ) - expect_true(".dy_member_contrast_assumed_exchangeable_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_arbitrary" %in% names(result)) + short_member_contrast <- paste0( + dyad_retained_prefix, + "member_contrast_arbitrary" + ) + + expect_true(short_member_contrast %in% names(result)) + expect_false( + ".member_contrast_assumed_exchangeable_arbitrary" %in% names(result) + ) expect_equal( - abs(result$.dy_member_contrast_assumed_exchangeable_arbitrary), + abs(result[[short_member_contrast]]), rep(1, 4) ) }) @@ -322,17 +372,17 @@ test_that("infer_dyad_compositions preserves unpooled exchangeable compositions" ) expect_equal(dyad_compositions$n_dyads, c(1L, 2L)) expect_equal( - as.character(result$.dy_composition), + as.character(result$.composition), c(rep("same_sex", 4), rep("friend_x_friend", 2)) ) expect_equal( - as.character(result$.dy_composition_role), + as.character(result$.composition_role), c(rep("same_sex", 4), rep("friend_x_friend", 2)) ) - expect_true(".dy_member_contrast_friend_x_friend_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_friend_x_friend" %in% names(result)) - expect_false(".dy_member_contrast_female_x_female_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_male_x_male_arbitrary" %in% names(result)) + expect_true(".member_contrast_friend_x_friend_arbitrary" %in% names(result)) + expect_false(".member_contrast_friend_x_friend" %in% names(result)) + expect_false(".member_contrast_female_x_female_arbitrary" %in% names(result)) + expect_false(".member_contrast_male_x_male_arbitrary" %in% names(result)) }) test_that("infer_dyad_compositions pools after setting compositions exchangeable", { @@ -364,9 +414,11 @@ test_that("infer_dyad_compositions pools after setting compositions exchangeable "female_x_female, female_x_male, male_x_male" ) expect_equal(dyad_compositions$n_dyads, 3L) - expect_true(".dy_is_romantic_couples" %in% names(result)) - expect_true(".dy_member_contrast_romantic_couples_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_romantic_couples" %in% names(result)) + expect_true(paste0(dyad_retained_prefix, "is_exchangeable") %in% names(result)) + expect_true( + paste0(dyad_retained_prefix, "member_contrast_arbitrary") %in% names(result) + ) + expect_false(".member_contrast_romantic_couples" %in% names(result)) }) test_that("infer_dyad_compositions rejects pooling distinguishable compositions", { @@ -387,6 +439,7 @@ test_that("infer_dyad_compositions rejects pooling distinguishable compositions" infer_dyad_compositions( validated, seed = 123, + include_arbitrary_member_contrast = TRUE, pool_compositions = list(couples = c("female-female", "female-male")) ), "can only pool exchangeable compositions", @@ -578,7 +631,7 @@ test_that("infer_dyad_compositions is not inflated by longitudinal rows", { result <- infer_dyad_compositions(validated, seed = 123) dyad_compositions <- attr(result, "dyadMLM")$dyad_compositions dyad_compositions <- dyad_compositions[order(dyad_compositions$composition), ] - indicator_names <- grep("^\\.dy_is_", names(result), value = TRUE) + indicator_names <- grep("^\\.is_", names(result), value = TRUE) expect_equal(dyad_compositions$composition, c("female_x_female", "female_x_male")) expect_equal(dyad_compositions$dyad_type, c("exchangeable", "distinguishable")) @@ -587,20 +640,20 @@ test_that("infer_dyad_compositions is not inflated by longitudinal rows", { expect_equal(dyad_compositions$n_dyads, c(1L, 1L)) expect_equal(rowSums(result[indicator_names]), rep(1, nrow(result))) expect_equal( - as.character(result$.dy_composition), + as.character(result$.composition), c("female_x_male", "female_x_male", "female_x_male", "female_x_male", "female_x_female", "female_x_female", "female_x_female", "female_x_female") ) expect_equal( - as.character(result$.dy_composition_role), + as.character(result$.composition_role), c("female_x_male_female", "female_x_male_male", "female_x_male_female", "female_x_male_male", "female_x_female", "female_x_female", "female_x_female", "female_x_female") ) - expect_true(".dy_member_contrast_female_x_female_arbitrary" %in% names(result)) - expect_equal(result$.dy_member_contrast_female_x_female_arbitrary[result$dyad_id == 1], rep(0, 4)) - expect_equal(abs(result$.dy_member_contrast_female_x_female_arbitrary[result$dyad_id == 2]), rep(1, 4)) + expect_true(".member_contrast_female_x_female_arbitrary" %in% names(result)) + expect_equal(result$.member_contrast_female_x_female_arbitrary[result$dyad_id == 1], rep(0, 4)) + expect_equal(abs(result$.member_contrast_female_x_female_arbitrary[result$dyad_id == 2]), rep(1, 4)) }) test_that("infer_dyad_compositions handles ragged longitudinal rows", { @@ -625,8 +678,8 @@ test_that("infer_dyad_compositions handles ragged longitudinal rows", { expect_equal(dyad_compositions$composition, c("female_x_female", "female_x_male")) expect_equal(dyad_compositions$n_dyads, c(1L, 1L)) - expect_equal(as.character(result$.dy_composition[result$dyad_id == 1]), rep("female_x_male", 3)) - expect_equal(as.character(result$.dy_composition[result$dyad_id == 2]), rep("female_x_female", 4)) + expect_equal(as.character(result$.composition[result$dyad_id == 1]), rep("female_x_male", 3)) + expect_equal(as.character(result$.composition[result$dyad_id == 2]), rep("female_x_female", 4)) }) test_that("infer_dyad_compositions creates formula-friendly indicator names", { @@ -645,8 +698,12 @@ test_that("infer_dyad_compositions creates formula-friendly indicator names", { result <- infer_dyad_compositions(validated, seed = 123) - expect_true(".dy_is_female_partner_x_male_partner_female_partner" %in% names(result)) - expect_true(".dy_is_female_partner_x_male_partner_male_partner" %in% names(result)) + expect_true( + paste0(dyad_retained_prefix, "is_female_partner") %in% names(result) + ) + expect_true( + paste0(dyad_retained_prefix, "is_male_partner") %in% names(result) + ) }) test_that("infer_dyad_compositions rejects generated indicator name collisions", { @@ -681,20 +738,28 @@ test_that("infer_dyad_compositions treats missing role metadata as unclassified" expect_false(".dy_raw_composition" %in% names(result)) expect_false(".dy_arbitrary_role" %in% names(result)) - expect_true(is.factor(result$.dy_composition)) - expect_true(is.factor(result$.dy_composition_role)) - expect_true(".dy_is_assumed_exchangeable" %in% names(result)) - expect_true(".dy_member_contrast_assumed_exchangeable_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_assumed_exchangeable" %in% names(result)) + expect_true(is.factor(result$.composition)) + expect_true(is.factor(result$.composition_role)) + short_member_contrast <- paste0( + dyad_retained_prefix, + "member_contrast_arbitrary" + ) + expect_true( + paste0(dyad_retained_prefix, "is_exchangeable") %in% names(result) + ) + expect_true(short_member_contrast %in% names(result)) + expect_false( + ".member_contrast_assumed_exchangeable_arbitrary" %in% names(result) + ) + expect_false(".member_contrast_assumed_exchangeable" %in% names(result)) expect_false(dyad_diff_col %in% names(result)) - expect_equal(abs(result$.dy_member_contrast_assumed_exchangeable_arbitrary), rep(1, 4)) + expect_equal(abs(result[[short_member_contrast]]), rep(1, 4)) expect_equal( - as.character(result$.dy_composition), + as.character(result$.composition), rep("assumed_exchangeable", 4) ) expect_equal( - as.character(result$.dy_composition_role), + as.character(result$.composition_role), rep("assumed_exchangeable", 4) ) expect_equal( diff --git a/tests/testthat/test-prepare_dyad_data.R b/tests/testthat/test-prepare_dyad_data.R index 96a87c42..1f9a5673 100644 --- a/tests/testthat/test-prepare_dyad_data.R +++ b/tests/testthat/test-prepare_dyad_data.R @@ -1,5 +1,10 @@ test_that("prepare_dyad_data has no outcome-selection argument", { expect_false("outcomes" %in% names(formals(prepare_dyad_data))) + expect_identical(formals(prepare_dyad_data)$short_colnames, TRUE) + expect_identical( + formals(prepare_dyad_data)$include_arbitrary_member_contrast, + FALSE + ) }) test_that("prepare_dyad_data returns validated data with dyad composition metadata", { @@ -47,25 +52,25 @@ test_that("prepare_dyad_data returns validated data with dyad composition metada ) expect_equal(dyad_compositions$n_dyads, c(1L, 1L, 1L)) expect_false(".dy_raw_composition" %in% names(result)) - expect_true(is.factor(result$.dy_composition)) - expect_true(is.factor(result$.dy_composition_role)) - indicator_names <- grep("^\\.dy_is_", names(result), value = TRUE) + expect_true(is.factor(result$.composition)) + expect_true(is.factor(result$.composition_role)) + indicator_names <- grep("^\\.is_", names(result), value = TRUE) expect_equal(rowSums(result[indicator_names]), rep(1, nrow(result))) expect_equal( - as.character(result$.dy_composition), + as.character(result$.composition), c("female_x_male", "female_x_male", "female_x_female", "female_x_female", "male_x_male", "male_x_male") ) expect_equal( - as.character(result$.dy_composition_role), + as.character(result$.composition_role), c("female_x_male_female", "female_x_male_male", "female_x_female", "female_x_female", "male_x_male", "male_x_male") ) - expect_true(".dy_member_contrast_female_x_female_arbitrary" %in% names(result)) - expect_true(".dy_member_contrast_male_x_male_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_female_x_female" %in% names(result)) - expect_false(".dy_member_contrast_male_x_male" %in% names(result)) + expect_true(".member_contrast_female_x_female_arbitrary" %in% names(result)) + expect_true(".member_contrast_male_x_male_arbitrary" %in% names(result)) + expect_false(".member_contrast_female_x_female" %in% names(result)) + expect_false(".member_contrast_male_x_male" %in% names(result)) }) test_that("prepare_dyad_data stores predictor metadata", { @@ -106,15 +111,15 @@ test_that("prepare_dyad_data centers longitudinal predictors", { seed = 123 ) - expect_true(".dy_x_cwp" %in% names(result)) - expect_true(".dy_x_cbp" %in% names(result)) - expect_equal(result$.dy_x_cwp, c(-1, -1, 1, 1, -1, -1, 1, 1)) + expect_true(".x_cwp" %in% names(result)) + expect_true(".x_cbp" %in% names(result)) + expect_equal(result$.x_cwp, c(-1, -1, 1, 1, -1, -1, 1, 1)) expect_equal( attr(result, "dyadMLM")$temporal_decompositions, tibble::tibble( predictor = c("x", "x", "x"), component = c("raw", "cwp", "cbp"), - column = c("x", ".dy_x_cwp", ".dy_x_cbp"), + column = c("x", ".x_cwp", ".x_cbp"), temporal_decomposition = c("none", "2l", "2l"), lag = c(0L, 0L, 0L) ) @@ -139,10 +144,10 @@ test_that("prepare_dyad_data constructs multiple requested model column families ) expect_equal(attr(result, "dyadMLM")$model_types, c("apim", "dim")) - expect_true(".dy_x_actor" %in% names(result)) - expect_true(".dy_x_partner" %in% names(result)) - expect_true(".dy_x_dyad_mean_gmc" %in% names(result)) - expect_true(".dy_x_within_dyad_dev" %in% names(result)) + expect_true(".x_actor" %in% names(result)) + expect_true(".x_partner" %in% names(result)) + expect_true(".x_dyad_mean_gmc" %in% names(result)) + expect_true(".x_within_dyad_dev" %in% names(result)) expect_s3_class(attr(result, "dyadMLM")$apim_predictors, "tbl_df") expect_s3_class(attr(result, "dyadMLM")$dim_predictors, "tbl_df") }) @@ -165,6 +170,169 @@ test_that("prepare_dyad_data rejects unsupported model types", { ) }) +test_that("prepare_dyad_data validates short_colnames", { + data <- data.frame( + dyad_id = c(1, 1, 2, 2), + person_id = c("A", "B", "C", "D") + ) + + for (short_colnames in list(NA, c(TRUE, FALSE), "yes")) { + expect_error( + prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + short_colnames = short_colnames + ), + "`short_colnames` must be `TRUE` or `FALSE`.", + fixed = TRUE + ) + } +}) + +test_that("prepare_dyad_data validates include_arbitrary_member_contrast", { + data <- data.frame( + dyad_id = c(1, 1, 2, 2), + person_id = c("A", "B", "C", "D") + ) + + for (include_arbitrary_member_contrast in list(NA, c(TRUE, FALSE), "yes")) { + expect_error( + prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + include_arbitrary_member_contrast = include_arbitrary_member_contrast + ), + "`include_arbitrary_member_contrast` must be `TRUE` or `FALSE`.", + fixed = TRUE + ) + } +}) + +test_that("prepare_dyad_data can contrast members without changing distinguishability", { + data <- data.frame( + dyad_id = rep(1:2, each = 8), + person_id = rep(rep(c("A", "B"), each = 4), 2), + role = rep(rep(c("female", "male"), each = 4), 2), + time = rep(1:4, 4) + ) + + default <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + role = role, + time = time, + model_types = "none", + seed = 123 + ) + result <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + role = role, + time = time, + model_types = "none", + seed = 123, + include_arbitrary_member_contrast = TRUE + ) + + expect_false(".member_contrast_arbitrary" %in% names(default)) + expect_true(".member_contrast_arbitrary" %in% names(result)) + expect_equal( + as.character(result$.composition_role), + as.character(default$.composition_role) + ) + expect_equal(result$.is_female, default$.is_female) + expect_equal(result$.is_male, default$.is_male) + expect_false(".is_exchangeable" %in% names(result)) + expect_equal( + attr(result, "dyadMLM")$dyad_compositions, + attr(default, "dyadMLM")$dyad_compositions + ) + expect_equal( + attr(result, "dyadMLM")$dyad_compositions$dyad_type, + "distinguishable" + ) + + member_contrasts <- result |> + dplyr::distinct( + .data$dyad_id, + .data$person_id, + .data$.member_contrast_arbitrary + ) + + expect_equal(nrow(member_contrasts), 4L) + expect_equal( + sort(member_contrasts$.member_contrast_arbitrary[ + member_contrasts$dyad_id == 1 + ]), + c(-1, 1) + ) + expect_equal( + sort(member_contrasts$.member_contrast_arbitrary[ + member_contrasts$dyad_id == 2 + ]), + c(-1, 1) + ) + + generated <- dyad_generated_columns(attr(result, "dyadMLM")) + member_contrast <- generated[ + generated$column_role == "member_contrast", + ] + expect_equal(nrow(member_contrast), 1L) + expect_equal(member_contrast$column, ".member_contrast_arbitrary") + + qualified <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + role = role, + time = time, + model_types = "none", + short_colnames = FALSE, + seed = 123, + include_arbitrary_member_contrast = TRUE + ) + expect_true( + ".member_contrast_female_x_male_arbitrary" %in% names(qualified) + ) + expect_false(any(grepl("male_x_female", names(qualified), fixed = TRUE))) +}) + +test_that("optional member contrasts respect generated-column collisions", { + data <- data.frame( + dyad_id = c(1, 1, 2, 2), + person_id = c("A", "B", "C", "D"), + role = c("female", "male", "female", "male"), + .member_contrast_arbitrary = 0, + check.names = FALSE + ) + + expect_no_error( + prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + role = role, + model_types = "none" + ) + ) + expect_error( + prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + role = role, + model_types = "none", + include_arbitrary_member_contrast = TRUE + ), + "Generated-column collision for `.member_contrast_arbitrary`", + fixed = TRUE + ) +}) + test_that("prepare_dyad_data can set a distinguishable composition exchangeable for DIM", { data <- data.frame( dyad_id = c(1, 1, 2, 2), @@ -186,10 +354,13 @@ test_that("prepare_dyad_data can set a distinguishable composition exchangeable ) expect_equal(attr(result, "dyadMLM")$dyad_compositions$dyad_type, "exchangeable") - expect_true(".dy_member_contrast_female_x_male_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_female_x_male" %in% names(result)) - expect_true(".dy_x_dyad_mean_gmc" %in% names(result)) - expect_true(".dy_x_within_dyad_dev" %in% names(result)) + expect_true(paste0(dyad_retained_prefix, "is_exchangeable") %in% names(result)) + expect_true( + paste0(dyad_retained_prefix, "member_contrast_arbitrary") %in% names(result) + ) + expect_false(".member_contrast_female_x_male_arbitrary" %in% names(result)) + expect_true(".x_dyad_mean_gmc" %in% names(result)) + expect_true(".x_within_dyad_dev" %in% names(result)) }) test_that("prepare_dyad_data can pool exchangeable compositions for DIM", { @@ -223,10 +394,13 @@ test_that("prepare_dyad_data can pool exchangeable compositions for DIM", { dyad_compositions$pooled_from, "female_x_female, female_x_male, male_x_male" ) - expect_true(".dy_member_contrast_romantic_couples_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_romantic_couples" %in% names(result)) - expect_true(".dy_x_dyad_mean_gmc" %in% names(result)) - expect_true(".dy_x_within_dyad_dev" %in% names(result)) + expect_true(paste0(dyad_retained_prefix, "is_exchangeable") %in% names(result)) + expect_true( + paste0(dyad_retained_prefix, "member_contrast_arbitrary") %in% names(result) + ) + expect_false(".member_contrast_romantic_couples_arbitrary" %in% names(result)) + expect_true(".x_dyad_mean_gmc" %in% names(result)) + expect_true(".x_within_dyad_dev" %in% names(result)) }) test_that("prepare_dyad_data treats data without role as assumed exchangeable dyads", { @@ -238,16 +412,18 @@ test_that("prepare_dyad_data treats data without role as assumed exchangeable dy result <- prepare_dyad_data(data, dyad = dyad_id, member = person_id, seed = 123) expect_false(".dy_raw_composition" %in% names(result)) - expect_true(is.factor(result$.dy_composition)) - expect_true(is.factor(result$.dy_composition_role)) - expect_true(".dy_is_assumed_exchangeable" %in% names(result)) + expect_true(is.factor(result$.composition)) + expect_true(is.factor(result$.composition_role)) + expect_true(paste0(dyad_retained_prefix, "is_exchangeable") %in% names(result)) expect_false(".dy_diff" %in% names(result)) - expect_true(".dy_member_contrast_assumed_exchangeable_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_arbitrary" %in% names(result)) - expect_false(".dy_member_contrast_assumed_exchangeable" %in% names(result)) - expect_equal(as.character(result$.dy_composition), rep("assumed_exchangeable", 4)) + expect_true( + paste0(dyad_retained_prefix, "member_contrast_arbitrary") %in% names(result) + ) + expect_false(".is_assumed_exchangeable" %in% names(result)) + expect_false(".member_contrast_assumed_exchangeable_arbitrary" %in% names(result)) + expect_equal(as.character(result$.composition), rep("assumed_exchangeable", 4)) expect_equal( - as.character(result$.dy_composition_role), + as.character(result$.composition_role), rep("assumed_exchangeable", 4) ) expect_equal( @@ -260,6 +436,26 @@ test_that("prepare_dyad_data treats data without role as assumed exchangeable dy n_dyads = 2L ) ) + + long_result <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + short_colnames = FALSE, + seed = 123 + ) + expect_true(".is_assumed_exchangeable" %in% names(long_result)) + expect_true( + ".member_contrast_assumed_exchangeable_arbitrary" %in% + names(long_result) + ) + expect_false( + paste0(dyad_retained_prefix, "is_exchangeable") %in% names(long_result) + ) + expect_false( + paste0(dyad_retained_prefix, "member_contrast_arbitrary") %in% + names(long_result) + ) }) test_that("prepare_dyad_data errors when setting compositions exchangeable without role", { @@ -390,12 +586,16 @@ test_that("prepare_dyad_data filters included compositions before finalizing met c("female_x_female", "male_x_male") ) expect_equal(dyad_compositions$n_dyads, c(1L, 1L)) - expect_equal(levels(result$.dy_composition), c("female_x_female", "male_x_male")) - expect_equal(levels(result$.dy_composition_role), c("female_x_female", "male_x_male")) - expect_true(".dy_is_female_x_female" %in% names(result)) - expect_true(".dy_is_male_x_male" %in% names(result)) - expect_true(".dy_member_contrast_female_x_female_arbitrary" %in% names(result)) - expect_true(".dy_member_contrast_male_x_male_arbitrary" %in% names(result)) + expect_equal(levels(result$.composition), c("female_x_female", "male_x_male")) + expect_equal(levels(result$.composition_role), c("female_x_female", "male_x_male")) + expect_true(".is_female_x_female" %in% names(result)) + expect_true(".is_male_x_male" %in% names(result)) + expect_true(".member_contrast_female_x_female_arbitrary" %in% names(result)) + expect_true(".member_contrast_male_x_male_arbitrary" %in% names(result)) + expect_false(any(paste0( + dyad_retained_prefix, + c("is_exchangeable", "member_contrast_arbitrary") + ) %in% names(result))) expect_false(any(grepl("female_x_male", names(result), fixed = TRUE))) expect_error( @@ -441,11 +641,17 @@ test_that("prepare_dyad_data filters before DIM compatibility checks", { expect_equal(meta$dyad_compositions$composition, "female_x_female") expect_equal(meta$dyad_compositions$dyad_type, "exchangeable") expect_equal(meta$dyad_compositions$n_dyads, 2L) - expect_equal(levels(result$.dy_composition), "female_x_female") + expect_equal(levels(result$.composition), "female_x_female") + expect_true(paste0(dyad_retained_prefix, "is_exchangeable") %in% names(result)) + expect_true( + paste0(dyad_retained_prefix, "member_contrast_arbitrary") %in% names(result) + ) + expect_false(".is_female_x_female" %in% names(result)) + expect_false(".member_contrast_female_x_female_arbitrary" %in% names(result)) expect_false(any(grepl("male_x_male", names(result), fixed = TRUE))) - expect_true(".dy_x_dyad_mean_gmc" %in% names(result)) - expect_true(".dy_x_within_dyad_dev" %in% names(result)) - expect_false(any(startsWith(names(result), ".dy_y_"))) + expect_true(".x_dyad_mean_gmc" %in% names(result)) + expect_true(".x_within_dyad_dev" %in% names(result)) + expect_false(any(startsWith(names(result), ".y_"))) expect_equal(meta$dim_predictors$predictor, "x") }) @@ -484,11 +690,15 @@ test_that("prepare_dyad_data can filter, constrain, and pool in one call", { expect_equal(dyad_compositions$dyad_type_source, "mixed") expect_equal(dyad_compositions$pooled_from, "female_x_female, female_x_male, male_x_male") expect_equal(dyad_compositions$n_dyads, 3L) - expect_equal(levels(result$.dy_composition), "romantic_couples") + expect_equal(levels(result$.composition), "romantic_couples") expect_false(any(grepl("nonbinary", names(result), fixed = TRUE))) - expect_true(".dy_member_contrast_romantic_couples_arbitrary" %in% names(result)) - expect_true(".dy_x_dyad_mean_gmc" %in% names(result)) - expect_true(".dy_x_within_dyad_dev" %in% names(result)) + expect_true(paste0(dyad_retained_prefix, "is_exchangeable") %in% names(result)) + expect_true( + paste0(dyad_retained_prefix, "member_contrast_arbitrary") %in% names(result) + ) + expect_false(".member_contrast_romantic_couples_arbitrary" %in% names(result)) + expect_true(".x_dyad_mean_gmc" %in% names(result)) + expect_true(".x_within_dyad_dev" %in% names(result)) expect_equal(attr(result, "dyadMLM")$dim_predictors$predictor, "x") }) @@ -607,9 +817,16 @@ test_that("prepare_dyad_data infers compositions from sparse longitudinal roles" time = time ) - expect_equal(as.character(result$.dy_composition), rep("female_x_male", 8)) + expect_equal(as.character(result$.composition), rep("female_x_male", 8)) expect_equal( - as.character(result$.dy_composition_role), + as.character(result$.composition_role), rep(c("female_x_male_female", "female_x_male_male"), 4) ) + expect_true(all( + paste0(dyad_retained_prefix, c("is_female", "is_male")) %in% names(result) + )) + expect_false(any(c( + ".is_female_x_male_female", + ".is_female_x_male_male" + ) %in% names(result))) }) diff --git a/tests/testthat/test-print-dyadMLM_data.R b/tests/testthat/test-print-dyadMLM_data.R index 87501902..0452ff6a 100644 --- a/tests/testthat/test-print-dyadMLM_data.R +++ b/tests/testthat/test-print-dyadMLM_data.R @@ -38,7 +38,7 @@ test_that("dyadMLM data prints a header before the tibble", { printed <- capture_wide_print(result) expect_true(any(grepl("# dyadMLM data", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_is_{comp-role}", printed, fixed = TRUE))) + expect_true(any(grepl(".is_{comp-role}", printed, fixed = TRUE))) expect_true(any(grepl("# A tibble:", printed, fixed = TRUE))) }) @@ -132,28 +132,38 @@ test_that("dyadMLM data print describes generated predictor columns", { ) printed <- capture_wide_print(result) + short_indicator_pattern <- paste0(dyad_retained_prefix, "is_{role}") + short_member_contrast_pattern <- paste0( + dyad_retained_prefix, + "member_contrast_arbitrary" + ) expect_false(any(grepl("sum-diff contrast for exchangeable dyads; 0 for distinguishable dyads", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_member_contrast_{comp}", printed, fixed = TRUE))) + expect_true(any(grepl(short_indicator_pattern, printed, fixed = TRUE))) + expect_true(any(grepl(short_member_contrast_pattern, printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_member_contrast_{comp}_arbitrary", - "composition-specific member contrasts with arbitrary direction; 0 for distinguishable dyads or other exchangeable compositions" + short_member_contrast_pattern, + paste( + "composition-specific member contrasts coded -1/+1 in arbitrary", + "direction for exchangeability-constrained random effects. Values are", + "0 for other compositions" + ) ) - expect_true(any(grepl(".dy_{pred}_actor", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_actor", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_actor", + ".{pred}_actor", "APIM actor predictor: actor's original predictor values" ) - expect_true(any(grepl(".dy_{pred}_partner", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_partner", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_partner", + ".{pred}_partner", "APIM partner predictor: partner's original predictor values" ) - expect_false(any(grepl(".dy_{pred}_actor actor", printed, fixed = TRUE))) - expect_false(any(grepl(".dy_{pred}_partner partner", printed, fixed = TRUE))) + expect_false(any(grepl(".{pred}_actor actor", printed, fixed = TRUE))) + expect_false(any(grepl(".{pred}_partner partner", printed, fixed = TRUE))) }) test_that("added column descriptions align and wrap to console width", { @@ -189,13 +199,21 @@ test_that("dyadMLM data print does not describe removed generated model column f seed = 123 ) - result$.dy_x_actor <- NULL + result$.x_actor <- NULL printed <- capture_wide_print(result) + short_member_contrast_pattern <- paste0( + dyad_retained_prefix, + "member_contrast_arbitrary" + ) - expect_false(any(grepl(".dy_{pred}_actor", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_partner", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_member_contrast_{comp}", printed, fixed = TRUE))) + expect_false(any(grepl(".{pred}_actor", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_partner", printed, fixed = TRUE))) + expect_true(any(grepl( + short_member_contrast_pattern, + printed, + fixed = TRUE + ))) }) test_that("dyadMLM data print describes longitudinal APIM columns", { @@ -217,24 +235,24 @@ test_that("dyadMLM data print describes longitudinal APIM columns", { printed <- capture_wide_print(result) - expect_true(any(grepl(".dy_{pred}_cwp", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cwp", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_cwp", + ".{pred}_cwp", "within-person predictor: momentary deviations from each person's usual level" ) - expect_true(any(grepl(".dy_{pred}_cbp", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cbp", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_cbp", + ".{pred}_cbp", "between-person predictor: stable differences from the average person's usual level" ) - expect_true(any(grepl(".dy_{pred}_actor", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_partner", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cwp_actor", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cwp_partner", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cbp_actor", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cbp_partner", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_actor", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_partner", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cwp_actor", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cwp_partner", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cbp_actor", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cbp_partner", printed, fixed = TRUE))) }) test_that("dyadMLM data print orders generated column descriptions", { @@ -261,9 +279,9 @@ test_that("dyadMLM data print orders generated column descriptions", { lines <- added_column_lines(capture_wide_print(result)) - expect_lt(added_column_index(lines, ".dy_{pred}_cwp"), added_column_index(lines, ".dy_{pred}_cwp_actor")) - expect_lt(added_column_index(lines, ".dy_{pred}_cbp"), added_column_index(lines, ".dy_{pred}_cbp_actor")) - expect_lt(added_column_index(lines, ".dy_{pred}_cbp_partner"), added_column_index(lines, ".dy_{pred}_cwp_dyad_mean")) + expect_lt(added_column_index(lines, ".{pred}_cwp"), added_column_index(lines, ".{pred}_cwp_actor")) + expect_lt(added_column_index(lines, ".{pred}_cbp"), added_column_index(lines, ".{pred}_cbp_actor")) + expect_lt(added_column_index(lines, ".{pred}_cbp_partner"), added_column_index(lines, ".{pred}_cwp_dyad_mean")) }) test_that("dyadMLM data print collapses repeated generated column types", { @@ -286,14 +304,14 @@ test_that("dyadMLM data print collapses repeated generated column types", { lines <- added_column_lines(capture_wide_print(result)) - expect_equal(added_column_count(lines, ".dy_{pred}_cwp"), 1) - expect_equal(added_column_count(lines, ".dy_{pred}_cbp"), 1) - expect_equal(added_column_count(lines, ".dy_{pred}_actor"), 1) - expect_equal(added_column_count(lines, ".dy_{pred}_partner"), 1) - expect_equal(added_column_count(lines, ".dy_{pred}_cwp_actor"), 1) - expect_equal(added_column_count(lines, ".dy_{pred}_cwp_partner"), 1) - expect_equal(added_column_count(lines, ".dy_{pred}_cbp_actor"), 1) - expect_equal(added_column_count(lines, ".dy_{pred}_cbp_partner"), 1) + expect_equal(added_column_count(lines, ".{pred}_cwp"), 1) + expect_equal(added_column_count(lines, ".{pred}_cbp"), 1) + expect_equal(added_column_count(lines, ".{pred}_actor"), 1) + expect_equal(added_column_count(lines, ".{pred}_partner"), 1) + expect_equal(added_column_count(lines, ".{pred}_cwp_actor"), 1) + expect_equal(added_column_count(lines, ".{pred}_cwp_partner"), 1) + expect_equal(added_column_count(lines, ".{pred}_cbp_actor"), 1) + expect_equal(added_column_count(lines, ".{pred}_cbp_partner"), 1) }) test_that("dyadMLM data print does not describe removed temporal source columns", { @@ -313,13 +331,13 @@ test_that("dyadMLM data print does not describe removed temporal source columns" seed = 123 ) - result$.dy_x_cwp <- NULL + result$.x_cwp <- NULL lines <- added_column_lines(capture_wide_print(result)) - expect_equal(added_column_count(lines, ".dy_{pred}_cwp"), 0) - expect_equal(added_column_count(lines, ".dy_{pred}_cbp"), 1) - expect_equal(added_column_count(lines, ".dy_{pred}_cwp_actor"), 1) + expect_equal(added_column_count(lines, ".{pred}_cwp"), 0) + expect_equal(added_column_count(lines, ".{pred}_cbp"), 1) + expect_equal(added_column_count(lines, ".{pred}_cwp_actor"), 1) }) test_that("dyadMLM data print describes cross-sectional DIM columns", { @@ -340,16 +358,16 @@ test_that("dyadMLM data print describes cross-sectional DIM columns", { printed <- capture_wide_print(result) - expect_true(any(grepl(".dy_{pred}_dyad_mean_gmc", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_dyad_mean_gmc", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_dyad_mean_gmc", + ".{pred}_dyad_mean_gmc", "dyad-mean predictor: dyad's average predictor level, grand-mean centered" ) - expect_true(any(grepl(".dy_{pred}_within_dyad_dev", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_within_dyad_dev", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_within_dyad_dev", + ".{pred}_within_dyad_dev", "DIM within-dyad member-deviation predictor: member's difference from the dyad mean" ) }) @@ -374,30 +392,30 @@ test_that("dyadMLM data print describes longitudinal DIM columns", { printed <- capture_wide_print(result) - expect_true(any(grepl(".dy_{pred}_dyad_mean_gmc", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_within_dyad_dev", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cwp_dyad_mean", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_dyad_mean_gmc", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_within_dyad_dev", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cwp_dyad_mean", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_cwp_dyad_mean", + ".{pred}_cwp_dyad_mean", "within-person dyad-mean predictor: shared momentary deviations in the dyad" ) - expect_true(any(grepl(".dy_{pred}_cwp_within_dyad_dev", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cwp_within_dyad_dev", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_cwp_within_dyad_dev", + ".{pred}_cwp_within_dyad_dev", "DIM within-person, within-dyad member-deviation predictor: member's momentary deviation from the dyad mean" ) - expect_true(any(grepl(".dy_{pred}_cbp_dyad_mean", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cbp_dyad_mean", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_cbp_dyad_mean", + ".{pred}_cbp_dyad_mean", "between-person dyad-mean predictor: dyad's stable usual level, grand-mean centered" ) - expect_true(any(grepl(".dy_{pred}_cbp_within_dyad_dev", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cbp_within_dyad_dev", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_cbp_within_dyad_dev", + ".{pred}_cbp_within_dyad_dev", "DIM between-person, within-dyad member-deviation predictor: member's stable difference from the dyad's usual level" ) }) @@ -426,16 +444,16 @@ test_that("dyadMLM data print describes longitudinal DSM predictors", { printed <- capture_wide_print(result) - expect_true(any(grepl(".dy_{pred}_cwp", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cbp", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cwp", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cbp", printed, fixed = TRUE))) expect_true(any(grepl("DSM direction: female - male", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_dsm_role_contrast", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_dyad_mean_gmc", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_within_dyad_diff", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cwp_dyad_mean", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cbp_dyad_mean", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cwp_within_dyad_diff", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_cbp_within_dyad_diff", printed, fixed = TRUE))) + expect_true(any(grepl(".dsm_role_contrast", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_dyad_mean_gmc", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_within_dyad_diff", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cwp_dyad_mean", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cbp_dyad_mean", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cwp_within_dyad_diff", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_cbp_within_dyad_diff", printed, fixed = TRUE))) expect_false(any(grepl("within_dyad_dev", printed, fixed = TRUE))) }) @@ -457,10 +475,10 @@ test_that("dyadMLM data print combines APIM and DIM column descriptions", { printed <- capture_wide_print(result) - expect_true(any(grepl(".dy_{pred}_actor", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_partner", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_dyad_mean_gmc", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_within_dyad_dev", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_actor", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_partner", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_dyad_mean_gmc", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_within_dyad_dev", printed, fixed = TRUE))) }) test_that("dyadMLM data print combines APIM and DSM predictors", { @@ -485,14 +503,14 @@ test_that("dyadMLM data print combines APIM and DSM predictors", { printed <- capture_wide_print(result) - expect_true(any(grepl(".dy_{pred}_actor", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_actor", printed, fixed = TRUE))) expect_added_column_description( printed, - ".dy_{pred}_actor", + ".{pred}_actor", "APIM actor predictor: actor's original predictor values" ) - expect_true(any(grepl(".dy_{pred}_dyad_mean_gmc", printed, fixed = TRUE))) - expect_true(any(grepl(".dy_{pred}_within_dyad_diff", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_dyad_mean_gmc", printed, fixed = TRUE))) + expect_true(any(grepl(".{pred}_within_dyad_diff", printed, fixed = TRUE))) }) test_that("dyadMLM data print describes dropped dyads with missing role information", { diff --git a/tests/testthat/test-public-api-cleanup.R b/tests/testthat/test-public-api-cleanup.R index 75ea2df2..b1b3dc9c 100644 --- a/tests/testthat/test-public-api-cleanup.R +++ b/tests/testthat/test-public-api-cleanup.R @@ -18,15 +18,20 @@ test_that("the public API and metadata use only the cleaned names", { getNamespaceExports("dyadMLM"), c( "prepare_dyad_data", - "compare_nested_glmmTMB_models", + "compare_nested_models", "recover_exchangeable_covariance" ) ) + expect_false(exists( + "compare_nested_glmmTMB_models", + envir = asNamespace("dyadMLM"), + inherits = FALSE + )) prepare_arguments <- names(formals(prepare_dyad_data)) expect_true(all(c( "dyad", "lag1_predictors", "model_types", "temporal_decomposition", - "keep_compositions" + "keep_compositions", "include_arbitrary_member_contrast" ) %in% prepare_arguments)) expect_false(any(c( "group", "lag_predictors", "model_type", @@ -91,19 +96,19 @@ test_that("DIM and DSM collision preflights cover suffixes and predictor order", collision_cases <- list( list( predictors = c("x", "x_cwp"), - target = ".dy_x_cwp_within_dyad_dev" + target = ".x_cwp_within_dyad_dev" ), list( predictors = c("x_cwp", "x"), - target = ".dy_x_cwp_within_dyad_dev" + target = ".x_cwp_within_dyad_dev" ), list( predictors = c("x", "x_cbp"), - target = ".dy_x_cbp_within_dyad_dev" + target = ".x_cbp_within_dyad_dev" ), list( predictors = c("x_cbp", "x"), - target = ".dy_x_cbp_within_dyad_dev" + target = ".x_cbp_within_dyad_dev" ) ) @@ -165,20 +170,107 @@ test_that("lag collisions with earlier generated columns are rejected", { model_types = "apim" ), paste0( - "`.dy_x_actor_lag1`.*predictor `x`.*lag 1.*model family `apim`.*", + "`.x_actor_lag1`.*predictor `x`.*lag 1.*model family `apim`.*", "predictor `x_actor`.*lag 1.*model family `temporal`" ), fixed = FALSE ) }) +test_that("generated names must be syntactically valid in formulas", { + data <- collision_test_data() + names(data)[names(data) == "x"] <- "1x" + + expect_error( + prepare_dyad_data( + data, + dyad = dyad_id, + member = member_id, + time = time, + predictors = tidyselect::all_of("1x"), + model_types = "apim", + temporal_decomposition = "none" + ), + "Generated column name `.1x_actor` is not syntactically valid in R.*Rename", + fixed = FALSE + ) +}) + +test_that("collision ownership uses the registry, not a name prefix", { + data <- tibble::tibble( + x = 1, + generated_short = 1, + original_short = 1 + ) + + generated_plan <- tibble::tibble( + target = "generated_short", + predictor = "x", + temporal_component = "raw", + lag = 0L, + model_family = "apim", + column_role = "actor", + variable_role = "predictor", + source_column = "x" + ) + data <- record_generated_columns(data, generated_plan) + + proposed_plan <- generated_plan + proposed_plan$model_family <- "temporal" + proposed_plan$column_role <- "temporal_component" + + expect_error( + validate_generated_column_plan(data, proposed_plan), + paste0( + "`generated_short`.*model family `temporal`.*", + "model family `apim`.*column role `actor`" + ) + ) + + proposed_plan$target <- "original_short" + expect_error( + validate_generated_column_plan(data, proposed_plan), + paste0( + "`original_short`.*model family `temporal`.*", + "model family `input`.*column role `original`" + ) + ) +}) + +test_that("composition columns cannot overwrite input columns", { + original_data <- data.frame( + dyad_id = c(1, 1, 2, 2), + member_id = c("a", "b", "c", "d") + ) + + for (column_name in c(".composition", ".composition_role")) { + data <- original_data + data[[column_name]] <- "original" + + expect_error( + prepare_dyad_data( + data, + dyad = dyad_id, + member = member_id, + model_types = "none" + ), + paste0( + "Generated-column collision for `", column_name, "`.*", + "model family `composition`.*model family `input`" + ), + fixed = FALSE + ) + } +}) + test_that("predictor columns cannot overwrite composition columns", { data <- data.frame( dyad_id = rep(1:2, each = 2), member_id = rep(c("a", "b"), 2), role = rep(c("actor", "f"), 2), - is_actor_x_f = 1:4 + is = 1:4 ) + collision_name <- paste0(dyad_retained_prefix, "is_actor") expect_error( prepare_dyad_data( @@ -186,29 +278,13 @@ test_that("predictor columns cannot overwrite composition columns", { dyad = dyad_id, member = member_id, role = role, - predictors = is_actor_x_f, + predictors = is, model_types = "apim" ), paste0( - "`.dy_is_actor_x_f_actor`.*predictor `is_actor_x_f`.*", + "`", collision_name, "`.*predictor `is`.*", "model family `apim`.*model family `composition`" ), fixed = FALSE ) }) - -test_that("only the new member contrast is generated", { - data <- collision_test_data() - prepared <- prepare_dyad_data( - data, - dyad = dyad_id, - member = member_id, - time = time, - model_types = "none", - seed = 1 - ) - expect_true( - ".dy_member_contrast_assumed_exchangeable_arbitrary" %in% names(prepared) - ) - expect_false(any(startsWith(names(prepared), ".dy_diff_"))) -}) diff --git a/tests/testthat/test-summary-dyadMLM_data.R b/tests/testthat/test-summary-dyadMLM_data.R new file mode 100644 index 00000000..71bc6315 --- /dev/null +++ b/tests/testthat/test-summary-dyadMLM_data.R @@ -0,0 +1,23 @@ +test_that("dyadMLM summary describes structure and summarizes all columns", { + data <- tibble::tibble( + dyad_id = c(1, 1, 2, 2), + person_id = 1:4, + score = c(1, NA, 3, 4) + ) + result <- prepare_dyad_data( + data, + dyad = dyad_id, + member = person_id, + seed = 123 + ) + + printed <- capture.output(returned <- summary(result)) + returned_names <- trimws(colnames(returned)) + + expect_true(any(grepl("# Summary of dyadMLM data", printed, fixed = TRUE))) + expect_true(any(grepl("# Column summaries:", printed, fixed = TRUE))) + expect_true("score" %in% returned_names) + generated_columns <- dyad_generated_columns(attr(result, "dyadMLM"))$column + expect_true(all(generated_columns %in% returned_names)) + expect_false("include_generated" %in% names(formals(summary.dyadMLM_data))) +}) diff --git a/vignettes/apim.Rmd b/vignettes/apim.Rmd index ffb0b705..92affbcc 100644 --- a/vignettes/apim.Rmd +++ b/vignettes/apim.Rmd @@ -51,26 +51,33 @@ A vignette for non-Gaussian generalized models is planned. # Cross-sectional APIMs +These examples use `add_apim_gmc_predictors = TRUE`, which retains raw APIM +columns and adds variants centered over all retained non-missing source values. +Using raw columns instead changes only the intercept reference. Do not include +both variants in a model with an intercept. + ## The distinguishable APIM A conceptual example for distinguishable female-male dyads: -```{r distinguishable-apim-diagram, echo=FALSE, fig.width=9, fig.height=4.8, out.width="100%", fig.cap="Conceptual cross-sectional APIM for distinguishable female-male dyads. Intercepts $b_\\mathrm{0}$, actor effects $a$, and partner effects $p$ can differ by the role of the outcome member (F and M), and the two outcome residuals covary within dyads.", fig.alt="Path diagram for a distinguishable cross-sectional APIM. Female and male outcomes have separate intercepts. Female and male predictors each have an actor path to their own outcome and a partner path to the other member's outcome. The female and male outcome residuals covary."} -draw_apim_diagram("distinguishable") +```{r distinguishable-apim-diagram, echo=FALSE, fig.width=9, fig.height=4.8, out.width="100%", fig.cap="Conceptual cross-sectional APIM for distinguishable female-male dyads, with both predictors centered using one pooled grand mean. Intercepts $b_\\mathrm{0}$, actor effects $a$, and partner effects $p$ can differ by the role of the outcome member (F and M), and the two outcome residuals covary within dyads.", fig.alt="Path diagram for a distinguishable cross-sectional APIM. Grand-mean-centered female and male predictors each have an actor path to their own outcome and a partner path to the other member's outcome. Female and male outcomes have separate intercepts, and their residuals covary."} +draw_apim_diagram("distinguishable", predictors_centered = TRUE) ``` For univariate MLM software like `glmmTMB`, this model is fitted in long format with one outcome row per member, which can be visualized as: -```{r distinguishable-apim-member-diagram, echo=FALSE, fig.width=9, fig.height=5.2, out.width="100%", fig.cap="Individual-level representation of the distinguishable cross-sectional APIM used for the long-format multilevel model. For the female outcome, the female predictor is the actor predictor and the male predictor is the partner predictor. These roles reverse for the male outcome. Intercepts, actor coefficients, and partner coefficients may differ by outcome role, and the two member residuals may have different variances and covary.", fig.alt="Two-panel path diagram for a distinguishable female-male APIM. The female and male outcomes have separate intercepts. In the female outcome panel, female X is the actor predictor and male X is the partner predictor of female Y, with coefficients a F and p F. In the male outcome panel, male X is the actor predictor and female X is the partner predictor of male Y, with coefficients a M and p M. The female and male outcome residuals covary."} -draw_apim_member_diagram("distinguishable") +```{r distinguishable-apim-member-diagram, echo=FALSE, fig.width=9, fig.height=5.2, out.width="100%", fig.cap="Individual-level representation of the distinguishable cross-sectional APIM used for the long-format multilevel model. Both predictors use one pooled grand-mean reference. For the female outcome, the female predictor is the actor predictor and the male predictor is the partner predictor. These roles reverse for the male outcome. Intercepts, actor coefficients, and partner coefficients may differ by outcome role, and the two member residuals may have different variances and covary.", fig.alt="Two-panel path diagram for a distinguishable female-male APIM with grand-mean-centered predictors. In the female outcome panel, female X is the actor predictor and male X is the partner predictor of female Y, with coefficients a F and p F. In the male outcome panel, male X is the actor predictor and female X is the partner predictor of male Y, with coefficients a M and p M. The outcomes have separate intercepts and their residuals covary."} +draw_apim_member_diagram("distinguishable", predictors_centered = TRUE) ``` ### Residual random-effects structure {#distinguishable-residual-structure} For a distinguishable female-male dyad, the two members can have different -residual variances. The within-dyad residual covariance block (shared across dyads) is: +residual variances. In the notation below, the member role is written first and +$i$ indexes dyads. The within-dyad residual covariance block (shared across +dyads) is: $$ \operatorname{Cov} @@ -78,7 +85,7 @@ $$ \epsilon_{Fi} \\ \epsilon_{Mi} \end{pmatrix} -= \boldsymbol{\Sigma}_{\epsilon} += \Sigma_{\epsilon} = \begin{bmatrix} \sigma_{\epsilon_F}^{2} & \rho_{\epsilon_F\epsilon_M}\sigma_{\epsilon_F}\sigma_{\epsilon_M} \\ @@ -90,18 +97,18 @@ $$ And the full residual covariance matrix for all dyads (first three shown) is then block-diagonal: $$ -\boldsymbol{\Sigma}_{\mathrm{model}} +\Sigma_{\mathrm{model}} = \begin{bmatrix} -\boldsymbol{\Sigma}_{\epsilon} & \boldsymbol{0} & \boldsymbol{0} & \cdots \\ -\boldsymbol{0} & \boldsymbol{\Sigma}_{\epsilon} & \boldsymbol{0} & \cdots \\ -\boldsymbol{0} & \boldsymbol{0} & \boldsymbol{\Sigma}_{\epsilon} & \cdots \\ +\Sigma_{\epsilon} & 0 & 0 & \cdots \\ +0 & \Sigma_{\epsilon} & 0 & \cdots \\ +0 & 0 & \Sigma_{\epsilon} & \cdots \\ \vdots & \vdots & \vdots & \ddots \end{bmatrix} $$ This structure is estimated with an unstructured random-effects block such as -`us(0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | coupleID)` +`us(0 + .is_female + .is_male | coupleID)` and `dispformula = ~ 0`. ### Fitting the distinguishable APIM with glmmTMB @@ -116,18 +123,20 @@ apim_distinguishable_data <- dyadMLM::prepare_dyad_data( role = gender, predictors = provided_support, model_types = "apim", + add_apim_gmc_predictors = TRUE, # All three observed compositions in `dyads_cross` are detected and retained by # default. This example focuses on `female-male` dyads, so we restrict the # analysis here. - keep_compositions = "female-male" + keep_compositions = "female-male", + include_arbitrary_member_contrast = TRUE, + seed = 123 ) print(apim_distinguishable_data, n=4) - ``` -The generated `.dy_*` columns can be used directly in the model formula. Here is -a simple example: +The optional member contrast is used later for the restricted model. It does +not change the composition's distinguishable metadata or role indicators. ```{r fit-cross-distinguishable-gaussian, eval = has_glmmTMB} apim_distinguishable_model <- glmmTMB::glmmTMB( @@ -135,23 +144,23 @@ apim_distinguishable_model <- glmmTMB::glmmTMB( # Gender-specific intercepts 0 + - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + + .is_female + + .is_male + # Gender-specific actor effects - .dy_is_female_x_male_female:.dy_provided_support_actor + - .dy_is_female_x_male_male:.dy_provided_support_actor + + .is_female:.provided_support_gmc_actor + + .is_male:.provided_support_gmc_actor + # Gender-specific partner effects - .dy_is_female_x_male_female:.dy_provided_support_partner + - .dy_is_female_x_male_male:.dy_provided_support_partner + + .is_female:.provided_support_gmc_partner + + .is_male:.provided_support_gmc_partner + # Dyad-level unstructured random effects represent the two partner # residual variances and their covariance when dispformula = ~ 0. # This is glmmTMB-specific syntax! `brms` uses different syntax. us(0 + - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + .is_female + + .is_male | coupleID) , dispformula = ~ 0 @@ -192,13 +201,16 @@ apim_distinguishable_fitted_alt <- sprintf( ) ``` -The estimated coefficients map as follows: +With the common centering, the two intercepts are the expected female and male +closeness scores when both partners' provided support equals the pooled sample +mean. The estimated coefficients map as follows: ```{r fitted-distinguishable-apim-diagram, echo=FALSE, eval=has_glmmTMB, fig.width=9, fig.height=4.8, out.width="100%", fig.cap="Fitted cross-sectional distinguishable APIM for the example data. Fixed effects, residual standard deviations, and the residual correlation are extracted from the fitted model.", fig.alt=apim_distinguishable_fitted_alt} draw_apim_diagram( "distinguishable", model = apim_distinguishable_model, - labels = c(predictor = "Provided support", outcome = "Closeness") + labels = c(predictor = "Provided support", outcome = "Closeness"), + predictors_centered = TRUE ) ``` @@ -206,8 +218,8 @@ draw_apim_diagram( Conceptually, the exchangeable APIM constrains several of the effects to be equal: -```{r exchangeable-apim-diagram, echo=FALSE, fig.width=9, fig.height=4.8, out.width="100%", fig.cap="Conceptual cross-sectional APIM for exchangeable dyads. The two members share one intercept, one actor effect, and one partner effect. Their outcome residuals have equal variances, yet still covary within dyads.", fig.alt="Path diagram for an exchangeable cross-sectional APIM. Both outcomes have the same intercept. Each member's predictor has the same actor effect on their own outcome and the same partner effect on the other member's outcome. The two outcome residuals have equal variances and covary."} -draw_apim_diagram("exchangeable") +```{r exchangeable-apim-diagram, echo=FALSE, fig.width=9, fig.height=4.8, out.width="100%", fig.cap="Conceptual cross-sectional APIM for exchangeable dyads, with both predictors centered using one pooled grand mean. The two members share one intercept, one actor effect, and one partner effect. Their outcome residuals have equal variances, yet still covary within dyads.", fig.alt="Path diagram for an exchangeable cross-sectional APIM with grand-mean-centered predictors. Both outcomes have the same intercept. Each member's predictor has the same actor effect on their own outcome and the same partner effect on the other member's outcome. The two outcome residuals have equal variances and covary."} +draw_apim_diagram("exchangeable", predictors_centered = TRUE) ``` Because the member labels are arbitrary, swapping members 1 and 2 does **not** @@ -216,8 +228,8 @@ change the model. To estimate this model in a univariate MLM framework, we can draw a conceptual diagram as such: -```{r exchangeable-apim-member-diagram, echo=FALSE, fig.width=9, fig.height=5.2, out.width="100%", fig.cap="Individual-level representation of the exchangeable cross-sectional APIM used for the long-format multilevel model. Both members share the same intercept. Each member's own predictor has the shared actor effect, and the other member's predictor has the shared partner effect. The two residual variances are equal and the residuals may covary.", fig.alt="Two-panel path diagram for an exchangeable APIM. Both outcomes have the same intercept. For arbitrary member 1, X 1 is the actor predictor and X 2 is the partner predictor of Y 1. For arbitrary member 2, X 2 is the actor predictor and X 1 is the partner predictor of Y 2. Both panels use the same actor coefficient a and partner coefficient p, and their outcome residuals covary."} -draw_apim_member_diagram("exchangeable") +```{r exchangeable-apim-member-diagram, echo=FALSE, fig.width=9, fig.height=5.2, out.width="100%", fig.cap="Individual-level representation of the exchangeable cross-sectional APIM used for the long-format multilevel model. Both predictors use one pooled grand-mean reference. The members share the same intercept; each member's own predictor has the shared actor effect, and the other member's predictor has the shared partner effect. The two residual variances are equal and the residuals may covary.", fig.alt="Two-panel path diagram for an exchangeable APIM with grand-mean-centered predictors. Both outcomes have the same intercept. For arbitrary member 1, X 1 is the actor predictor and X 2 is the partner predictor of Y 1. For arbitrary member 2, X 2 is the actor predictor and X 1 is the partner predictor of Y 2. Both panels use the same actor coefficient a and partner coefficient p, and their outcome residuals covary."} +draw_apim_member_diagram("exchangeable", predictors_centered = TRUE) ``` @@ -232,7 +244,7 @@ slopes, whereas separate structures would omit their correlations. The shared/difference representation works for residuals and other random-effect terms, including random slopes. Following @delrosarioPracticalGuideSpecifying2025, `dyadMLM::prepare_dyad_data()` -generates an arbitrary member-difference column, named `.dy_member_contrast_*`. +generates an arbitrary member-difference column, named `.member_contrast_*`. This contrast is `+1` for one member and `-1` for the other. The exchangeable residual structure is represented by two separate random-effects terms: a shared dyad random intercept and a random coefficient for this difference @@ -244,29 +256,13 @@ function that back-transforms the structure to the often more interpretable member-level residual covariance matrix. -### Fitting the exchangeable APIM with glmmTMB - -We use the same dataset as before, but do not distinguish males and females. -We can test distinguishability later by comparing this model with the prior -model. - -We use `set_exchangeable_compositions` for the exchangeability constraints. -Another option would be to omit roles. - -```{r prepare-cross-distinguishability} -apim_exchangeable_data <- dyadMLM::prepare_dyad_data( - dyads_cross, - dyad = coupleID, - member = personID, - role = gender, - predictors = provided_support, - keep_compositions = "female-male", - set_exchangeable_compositions = "female-male", - seed = 123 -) +### Fitting the restricted exchangeable APIM with glmmTMB -print(apim_exchangeable_data, n = 4) -``` +The restricted model omits gender-specific fixed effects and uses the +shared/difference residual representation. We reuse +`apim_distinguishable_data`, so both models use exactly the same prepared rows +and centering. `set_exchangeable_compositions` would instead reclassify the +composition when it should be treated as exchangeable throughout an analysis. We then use the columns to fit the model as follows: @@ -278,16 +274,16 @@ apim_exchangeable_model <- glmmTMB::glmmTMB( 1 + # Pooled single actor and partner effects - .dy_provided_support_actor + - .dy_provided_support_partner + + .provided_support_gmc_actor + + .provided_support_gmc_partner + # Residual variance covariance matrix via the shared/difference # specification in two uncorrelated blocks us(1 | coupleID) + - us(0 + .dy_member_contrast_female_x_male_arbitrary | coupleID), + us(0 + .member_contrast_arbitrary | coupleID), dispformula = ~ 0, family = gaussian(), - data = apim_exchangeable_data + data = apim_distinguishable_data ) summary(apim_exchangeable_model) @@ -349,13 +345,16 @@ apim_exchangeable_fitted_alt <- sprintf( -The output can now be mapped as follows: +With the common centering, the shared intercept is the expected closeness of +either member when both partners' provided support equals the pooled sample +mean. The output can now be mapped as follows: ```{r fitted-exchangeable-apim-diagram, echo=FALSE, eval=has_glmmTMB, fig.width=9, fig.height=4.8, out.width="100%", fig.cap="Fitted cross-sectional exchangeable APIM for the example data. The common member residual standard deviation and residual correlation are back-transformed from the fitted mean and difference components.", fig.alt=apim_exchangeable_fitted_alt} draw_apim_diagram( "exchangeable", model = apim_exchangeable_model, - labels = c(predictor = "Provided support", outcome = "Closeness") + labels = c(predictor = "Provided support", outcome = "Closeness"), + predictors_centered = TRUE ) ``` @@ -366,15 +365,15 @@ roles may differ with a restricted exchangeable model. This comparison tests the imposed equality constraints jointly. Here, they concern the fixed intercepts, actor effects, partner effects, and residual variances. -The two parameterizations require different generated columns, but both models -above use the same original observations. +Both models use the same prepared data object. The full model uses its retained +role indicators. The restricted model instead uses the opt-in arbitrary member +contrast for the exchangeability-constrained residual structure. -[`dyadMLM::compare_nested_glmmTMB_models()`](https://pascal-kueng.github.io/dyadMLM/reference/compare_nested_glmmTMB_models.html) -verifies that both models use equivalent original +`dyadMLM::compare_nested_models()` verifies that both models use equivalent original observations before performing the likelihood-ratio test: ```{r compare-cross-distinguishability, eval = has_glmmTMB} -dyadMLM::compare_nested_glmmTMB_models( +dyadMLM::compare_nested_models( apim_exchangeable_model, apim_distinguishable_model ) @@ -438,34 +437,34 @@ ild_distinguishable_model <- glmmTMB::glmmTMB( 0 + # Role-specific intercepts - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + + .is_female + + .is_male + # Role-specific time trends - .dy_is_female_x_male_female:diaryday_gmc + - .dy_is_female_x_male_male:diaryday_gmc + + .is_female:diaryday_gmc + + .is_male:diaryday_gmc + # Role-specific within-person actor effects - .dy_is_female_x_male_female:.dy_provided_support_cwp_actor + - .dy_is_female_x_male_male:.dy_provided_support_cwp_actor + + .is_female:.provided_support_cwp_actor + + .is_male:.provided_support_cwp_actor + # Role-specific within-person partner effects - .dy_is_female_x_male_female:.dy_provided_support_cwp_partner + - .dy_is_female_x_male_male:.dy_provided_support_cwp_partner + + .is_female:.provided_support_cwp_partner + + .is_male:.provided_support_cwp_partner + # Role-specific between-person actor effects - .dy_is_female_x_male_female:.dy_provided_support_cbp_actor + - .dy_is_female_x_male_male:.dy_provided_support_cbp_actor + + .is_female:.provided_support_cbp_actor + + .is_male:.provided_support_cbp_actor + # Role-specific between-person partner effects - .dy_is_female_x_male_female:.dy_provided_support_cbp_partner + - .dy_is_female_x_male_male:.dy_provided_support_cbp_partner + + .is_female:.provided_support_cbp_partner + + .is_male:.provided_support_cbp_partner + # Stable dyad-level covariance - us(0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | coupleID) + + us(0 + .is_female + .is_male | coupleID) + # Same-occasion covariance - us(0 + .dy_is_female_x_male_female + .dy_is_female_x_male_male | + us(0 + .is_female + .is_male | coupleID:diaryday), dispformula = ~ 0, family = gaussian(), @@ -481,10 +480,10 @@ replacing the stable dyad-level block above with: ```{r ild-distinguishable-random-slopes, eval = FALSE} us( 0 + - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + - .dy_is_female_x_male_female:.dy_provided_support_cwp_actor + - .dy_is_female_x_male_male:.dy_provided_support_cwp_actor + .is_female + + .is_male + + .is_female:.provided_support_cwp_actor + + .is_male:.provided_support_cwp_actor | coupleID ) ``` @@ -539,23 +538,23 @@ ild_apim_model <- glmmTMB::glmmTMB( diaryday + # Within-person actor and partner effects - .dy_provided_support_cwp_actor + - .dy_provided_support_cwp_partner + + .provided_support_cwp_actor + + .provided_support_cwp_partner + # Between-person actor and partner effects - .dy_provided_support_cbp_actor + - .dy_provided_support_cbp_partner + + .provided_support_cbp_actor + + .provided_support_cbp_partner + # Stable exchangeable dyad-level covariance with actor random slopes - us(1 + .dy_provided_support_cwp_actor | coupleID) + # shared intercept and slope - us(0 + .dy_member_contrast_female_x_female_arbitrary + # difference intercept - .dy_member_contrast_female_x_female_arbitrary: - .dy_provided_support_cwp_actor # difference slope + us(1 + .provided_support_cwp_actor | coupleID) + # shared intercept and slope + us(0 + .member_contrast_arbitrary + # difference intercept + .member_contrast_arbitrary: + .provided_support_cwp_actor # difference slope | coupleID) + # Same-occasion exchangeable covariance us(1 | coupleID:diaryday) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID:diaryday) + us(0 + .member_contrast_arbitrary | coupleID:diaryday) , dispformula = ~ 0 , family = gaussian() @@ -602,14 +601,14 @@ ild_apim_no_contrast_slope <- update( ild_apim_model, formula = . ~ . - us(0 + - .dy_member_contrast_female_x_female_arbitrary + - .dy_member_contrast_female_x_female_arbitrary: - .dy_provided_support_cwp_actor + .member_contrast_arbitrary + + .member_contrast_arbitrary: + .provided_support_cwp_actor | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID) + us(0 + .member_contrast_arbitrary | coupleID) ) -dyadMLM::compare_nested_glmmTMB_models( +dyadMLM::compare_nested_models( ild_apim_no_contrast_slope, ild_apim_model ) @@ -629,11 +628,11 @@ no_contrast_slope_covariance <- dyadMLM::recover_exchangeable_covariance( block_pairings = list( dyad = list( shared_block = - "us(1 + .dy_provided_support_cwp_actor | coupleID)", + "us(1 + .provided_support_cwp_actor | coupleID)", difference_block = - "us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID)", + "us(0 + .member_contrast_arbitrary | coupleID)", difference_indicator = - ".dy_member_contrast_female_x_female_arbitrary" + ".member_contrast_arbitrary" ) ) ) @@ -650,13 +649,13 @@ ild_apim_no_contrast_block <- update( ild_apim_model, formula = . ~ . - us(0 + - .dy_member_contrast_female_x_female_arbitrary + - .dy_member_contrast_female_x_female_arbitrary: - .dy_provided_support_cwp_actor + .member_contrast_arbitrary + + .member_contrast_arbitrary: + .provided_support_cwp_actor | coupleID) ) -dyadMLM::compare_nested_glmmTMB_models( +dyadMLM::compare_nested_models( ild_apim_no_contrast_block, ild_apim_model ) @@ -672,10 +671,10 @@ no_contrast_block_covariance <- dyadMLM::recover_exchangeable_covariance( block_pairings = list( dyad = list( shared_block = - "us(1 + .dy_provided_support_cwp_actor | coupleID)", + "us(1 + .provided_support_cwp_actor | coupleID)", difference_block = NULL, difference_indicator = - ".dy_member_contrast_female_x_female_arbitrary" + ".member_contrast_arbitrary" ) ) ) @@ -752,21 +751,21 @@ stability_influence <- glmmTMB::glmmTMB( closeness ~ 1 + # Stability (actor effect across time) - .dy_closeness_actor_lag1 + + .closeness_actor_lag1 + # Influence (partner effect across time) - .dy_closeness_partner_lag1 + + .closeness_partner_lag1 + # Linear time trend diaryday + # Stable exchangeable dyad-level covariance us(1 | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID) + + us(0 + .member_contrast_arbitrary | coupleID) + # Same-day exchangeable dyad-level covariance us(1 | coupleID:diaryday) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID:diaryday) + us(0 + .member_contrast_arbitrary | coupleID:diaryday) , dispformula = ~ 0 , family = gaussian() @@ -783,8 +782,8 @@ contemporaneous coefficients are then conditional on both partners' prior outcomes. The model above uses raw lagged outcomes. The corresponding -within-person-centered lagged terms are `.dy_closeness_cwp_actor_lag1` and -`.dy_closeness_cwp_partner_lag1`. +within-person-centered lagged terms are `.closeness_cwp_actor_lag1` and +`.closeness_cwp_partner_lag1`. Whether to use a raw or within-person-centered lagged outcome depends on the research question and the data. Person-mean centering the outcome lag can bias diff --git a/vignettes/diagram-helpers.Rinc b/vignettes/diagram-helpers.Rinc index ab65f134..818541b0 100644 --- a/vignettes/diagram-helpers.Rinc +++ b/vignettes/diagram-helpers.Rinc @@ -448,7 +448,10 @@ rm( .diagram_resolve_term( fixed_names, terms[[parameter]], function(term) { - role_match <- grepl(paste0("\\.dy_is_.*_", role, "($|:)"), term) + role_match <- grepl( + paste0("\\.is_(.*_)?", role, "($|:)"), + term + ) if (is.null(field)) { return(role_match && !grepl(":", term)) } @@ -469,12 +472,12 @@ rm( ) random_female <- .diagram_resolve_term( components$random_terms, terms$random_female, - function(term) grepl("\\.dy_is_.*_female$", term), + function(term) grepl("\\.is_(.*_)?female$", term), "random_female", "random-effect" ) random_male <- .diagram_resolve_term( components$random_terms, terms$random_male, - function(term) grepl("\\.dy_is_.*_male$", term), + function(term) grepl("\\.is_(.*_)?male$", term), "random_male", "random-effect" ) @@ -512,7 +515,7 @@ rm( intercept <- resolve_fixed( "intercept", function(term) term == "(Intercept)" || - (grepl("^\\.dy_is_", term) && !grepl(":", term)) + (grepl("^\\.is_", term) && !grepl(":", term)) ) actor <- resolve_fixed( "actor", function(term) grepl("_actor$", term) && !grepl(":", term) @@ -522,12 +525,12 @@ rm( ) random_mean <- .diagram_resolve_term( components$random_terms, terms$random_mean, - function(term) term == "(Intercept)" || grepl("^\\.dy_is_", term), + function(term) term == "(Intercept)" || grepl("^\\.is_", term), "random_mean", "random-effect" ) random_difference <- .diagram_resolve_term( components$random_terms, terms$random_difference, - function(term) grepl("^\\.dy_member_contrast_", term), + function(term) grepl("^\\.member_contrast_", term), "random_difference", "random-effect" ) mean_sd <- .extract_diagram_random_sd(components$random, random_mean) @@ -566,7 +569,7 @@ rm( } b0 <- resolve_fixed( "b0", function(term) term == "(Intercept)" || - (grepl("^\\.dy_is_", term) && !grepl(":", term)) + (grepl("^\\.is_", term) && !grepl(":", term)) ) b_mean <- resolve_fixed( "b_mean", function(term) grepl("_dyad_mean_gmc$", term) @@ -576,12 +579,12 @@ rm( ) random_mean <- .diagram_resolve_term( components$random_terms, terms$random_mean, - function(term) term == "(Intercept)" || grepl("^\\.dy_is_", term), + function(term) term == "(Intercept)" || grepl("^\\.is_", term), "random_mean", "random-effect" ) random_difference <- .diagram_resolve_term( components$random_terms, terms$random_difference, - function(term) grepl("^\\.dy_member_contrast_", term), + function(term) grepl("^\\.member_contrast_", term), "random_difference", "random-effect" ) @@ -630,15 +633,15 @@ rm( "a12", function(term) grepl("_within_dyad_diff$", term) && !grepl(":", term) ) a20 <- resolve_fixed( - "a20", function(term) term == ".dy_dsm_role_contrast" + "a20", function(term) term == ".dsm_role_contrast" ) a21 <- resolve_fixed( "a21", function(term) grepl("_dyad_mean_gmc", term) && - grepl("\\.dy_dsm_role_contrast", term) && grepl(":", term) + grepl("\\.dsm_role_contrast", term) && grepl(":", term) ) a22 <- resolve_fixed( "a22", function(term) grepl("_within_dyad_diff", term) && - grepl("\\.dy_dsm_role_contrast", term) && grepl(":", term) + grepl("\\.dsm_role_contrast", term) && grepl(":", term) ) random_mean <- .diagram_resolve_term( components$random_terms, terms$random_mean, @@ -647,7 +650,7 @@ rm( ) random_difference <- .diagram_resolve_term( components$random_terms, terms$random_difference, - function(term) term == ".dy_dsm_role_contrast", + function(term) term == ".dsm_role_contrast", "random_difference", "random-effect" ) @@ -684,13 +687,18 @@ draw_apim_diagram <- function( terms = NULL, show_residuals = TRUE, labels = NULL, - p_values = NULL) { + p_values = NULL, + predictors_centered = FALSE) { type <- match.arg(type) labels <- .diagram_variable_labels(labels) if (!is.logical(show_residuals) || length(show_residuals) != 1L || is.na(show_residuals)) { stop("`show_residuals` must be TRUE or FALSE.", call. = FALSE) } + if (!is.logical(predictors_centered) || length(predictors_centered) != 1L || + is.na(predictors_centered)) { + stop("`predictors_centered` must be TRUE or FALSE.", call. = FALSE) + } if (!is.null(model)) { if (!is.null(estimates) || !is.null(p_values) || !is.null(residuals)) { @@ -716,8 +724,12 @@ draw_apim_diagram <- function( if (type == "distinguishable") { node_labels <- list( - x_top = expression(X[plain(F)]), - x_bottom = expression(X[plain(M)]), + x_top = if (predictors_centered) { + expression(X[plain(F)] - mu[X]) + } else expression(X[plain(F)]), + x_bottom = if (predictors_centered) { + expression(X[plain(M)] - mu[X]) + } else expression(X[plain(M)]), y_top = expression(Y[plain(F)]), y_bottom = expression(Y[plain(M)]), e_top = expression(epsilon[plain(F)]), @@ -741,8 +753,12 @@ draw_apim_diagram <- function( required_residuals <- c("sd_female", "sd_male", "correlation") } else { node_labels <- list( - x_top = expression(X[1]), - x_bottom = expression(X[2]), + x_top = if (predictors_centered) { + expression(X[1] - mu[X]) + } else expression(X[1]), + x_bottom = if (predictors_centered) { + expression(X[2] - mu[X]) + } else expression(X[2]), y_top = expression(Y[1]), y_bottom = expression(Y[2]), e_top = expression(epsilon[1]), @@ -888,7 +904,7 @@ draw_apim_diagram <- function( type = "closed" ) - draw_node <- function(x, y, label) { + draw_node <- function(x, y, label, subtitle = NULL) { node_fontsize <- if (is.null(labels)) 20 else 18 if (is.list(label) && !is.expression(label)) { line_labels <- lapply(label, .diagram_math_label) @@ -912,21 +928,37 @@ draw_apim_diagram <- function( grid::grid.text( label, x = native(x), - y = native(y), + y = native(y + if (is.null(subtitle)) 0 else 0.025), gp = grid::gpar(col = ink_colour, fontsize = node_fontsize) ) } else { + line_offset <- if (is.null(subtitle)) 0.035 else 0.050 + line_gap <- if (is.null(subtitle)) 0.070 else 0.045 grid::grid.text( line_labels[[1]], x = native(x), - y = native(y + 0.035), - gp = grid::gpar(col = ink_colour, fontsize = node_fontsize) + y = native(y + line_offset), + gp = grid::gpar( + col = ink_colour, + fontsize = node_fontsize - if (is.null(subtitle)) 0 else 1 + ) ) grid::grid.text( line_labels[[2]], x = native(x), - y = native(y - 0.035), - gp = grid::gpar(col = ink_colour, fontsize = node_fontsize) + y = native(y + line_offset - line_gap), + gp = grid::gpar( + col = ink_colour, + fontsize = node_fontsize - if (is.null(subtitle)) 0 else 1 + ) + ) + } + if (!is.null(subtitle)) { + grid::grid.text( + subtitle, + x = native(x), + y = native(y - 0.060), + gp = grid::gpar(col = muted_colour, fontsize = 10) ) } } @@ -999,8 +1031,9 @@ draw_apim_diagram <- function( grid::pushViewport(grid::viewport(xscale = c(0, 1), yscale = c(0, 1))) grid::grid.rect(gp = grid::gpar(fill = "white", col = NA)) - draw_node(0.17, 0.72, node_labels$x_top) - draw_node(0.17, 0.28, node_labels$x_bottom) + predictor_subtitle <- if (predictors_centered) "GM-centered" else NULL + draw_node(0.17, 0.72, node_labels$x_top, predictor_subtitle) + draw_node(0.17, 0.28, node_labels$x_bottom, predictor_subtitle) draw_node(0.64, 0.72, node_labels$y_top) draw_node(0.64, 0.28, node_labels$y_bottom) draw_intercept(0.64, 0.86, intercept_labels$top) @@ -1118,8 +1151,13 @@ draw_apim_diagram <- function( } draw_apim_member_diagram <- function( - type = c("distinguishable", "exchangeable")) { + type = c("distinguishable", "exchangeable"), + predictors_centered = FALSE) { type <- match.arg(type) + if (!is.logical(predictors_centered) || length(predictors_centered) != 1L || + is.na(predictors_centered)) { + stop("`predictors_centered` must be TRUE or FALSE.", call. = FALSE) + } actor_colour <- .interdep_diagram_colours$actor partner_colour <- .interdep_diagram_colours$partner @@ -1132,10 +1170,18 @@ draw_apim_member_diagram <- function( panel_top = "Female outcome member", panel_bottom = "Male outcome member", actor_subtitle = "Actor predictor", - actor_x_top = expression(X[plain(F)]), - partner_x_top = expression(X[plain(M)]), - actor_x_bottom = expression(X[plain(M)]), - partner_x_bottom = expression(X[plain(F)]), + actor_x_top = if (predictors_centered) { + expression(X[plain(F)] - mu[X]) + } else expression(X[plain(F)]), + partner_x_top = if (predictors_centered) { + expression(X[plain(M)] - mu[X]) + } else expression(X[plain(M)]), + actor_x_bottom = if (predictors_centered) { + expression(X[plain(M)] - mu[X]) + } else expression(X[plain(M)]), + partner_x_bottom = if (predictors_centered) { + expression(X[plain(F)] - mu[X]) + } else expression(X[plain(F)]), y_top = expression(Y[plain(F)]), y_bottom = expression(Y[plain(M)]), residual_top = expression(epsilon[plain(F)]), @@ -1152,10 +1198,18 @@ draw_apim_member_diagram <- function( panel_top = "Arbitrary member 1", panel_bottom = "Arbitrary member 2", actor_subtitle = "Own predictor", - actor_x_top = expression(X[1]), - partner_x_top = expression(X[2]), - actor_x_bottom = expression(X[2]), - partner_x_bottom = expression(X[1]), + actor_x_top = if (predictors_centered) { + expression(X[1] - mu[X]) + } else expression(X[1]), + partner_x_top = if (predictors_centered) { + expression(X[2] - mu[X]) + } else expression(X[2]), + actor_x_bottom = if (predictors_centered) { + expression(X[2] - mu[X]) + } else expression(X[2]), + partner_x_bottom = if (predictors_centered) { + expression(X[1] - mu[X]) + } else expression(X[1]), y_top = expression(Y[1]), y_bottom = expression(Y[2]), residual_top = expression(epsilon[1]), @@ -2381,42 +2435,42 @@ draw_dim_member_diagram <- function() { fixed_terms <- c( intercept_fm_female = resolve_exact( - fixed_names, "intercept_fm_female", ".dy_is_female_x_male_female" + fixed_names, "intercept_fm_female", ".is_female_x_male_female" ), intercept_fm_male = resolve_exact( - fixed_names, "intercept_fm_male", ".dy_is_female_x_male_male" + fixed_names, "intercept_fm_male", ".is_female_x_male_male" ), intercept_ff = resolve_exact( - fixed_names, "intercept_ff", ".dy_is_female_x_female" + fixed_names, "intercept_ff", ".is_female_x_female" ), intercept_mm = resolve_exact( - fixed_names, "intercept_mm", ".dy_is_male_x_male" + fixed_names, "intercept_mm", ".is_male_x_male" ) ) random_terms <- c( random_fm_female = resolve_exact( components$random_terms, "random_fm_female", - ".dy_is_female_x_male_female", "random-effect" + ".is_female_x_male_female", "random-effect" ), random_fm_male = resolve_exact( components$random_terms, "random_fm_male", - ".dy_is_female_x_male_male", "random-effect" + ".is_female_x_male_male", "random-effect" ), random_ff_mean = resolve_exact( components$random_terms, "random_ff_mean", - ".dy_is_female_x_female", "random-effect" + ".is_female_x_female", "random-effect" ), random_ff_difference = resolve_exact( components$random_terms, "random_ff_difference", - ".dy_member_contrast_female_x_female_arbitrary", "random-effect" + ".member_contrast_female_x_female_arbitrary", "random-effect" ), random_mm_mean = resolve_exact( components$random_terms, "random_mm_mean", - ".dy_is_male_x_male", "random-effect" + ".is_male_x_male", "random-effect" ), random_mm_difference = resolve_exact( components$random_terms, "random_mm_difference", - ".dy_member_contrast_male_x_male_arbitrary", "random-effect" + ".member_contrast_male_x_male_arbitrary", "random-effect" ) ) diff --git a/vignettes/dim.Rmd b/vignettes/dim.Rmd index bba0a035..8cda81b3 100644 --- a/vignettes/dim.Rmd +++ b/vignettes/dim.Rmd @@ -81,6 +81,7 @@ cross_exchangeable_data <- dyadMLM::prepare_dyad_data( predictors = provided_support, # Create both APIM and DIM columns for comparison. model_types = c("apim", "dim"), + add_apim_gmc_predictors = TRUE, # All three observed compositions in `dyads_cross` are detected and retained by # default. This example focuses on `female-female` dyads, so we restrict the # analysis here. @@ -93,21 +94,31 @@ print(cross_exchangeable_data, n = 4) ``` For the exchangeable random-effects specification, -`dyadMLM::prepare_dyad_data()` creates a member-difference contrast `.dy_member_contrast_*`, +`dyadMLM::prepare_dyad_data()` creates a member-difference contrast `.member_contrast_*`, coded as `+1` for one partner and `-1` for the other. Because these member labels are arbitrary, setting `seed` makes their assignment reproducible. ### Example DIM Model -For member \(i \in \{1, 2\}\) of dyad \(j\), define the dyad mean and -within-dyad member deviation as: +Here $x_{ij}$ denotes provided support centered with the pooled mean from +complete predictor pairs. `prepare_dyad_data()` creates the corresponding DIM +dyad-mean column; using the original zero requires shifting it manually. + +For member $i \in \{1, 2\}$ of dyad $j$, define the dyad mean and within-dyad +member deviation as: $$ \bar{x}_j = \frac{x_{1j} + x_{2j}}{2}, \qquad x_{\mathrm{dev},ij} = x_{ij} - \bar{x}_j. $$ -The model uses $\bar{x}_j-\mu_x$, the grand-mean-centered dyad mean. +Because each $x_{ij}$ uses the same grand-mean reference, $\bar{x}_j$ is already +grand-mean centered. The within-dyad deviation is unchanged by this common +shift. + +APIM GMC uses all retained non-missing values, whereas DIM uses complete pairs. +The constants agree here; with one-sided missingness, intercept references may +differ although the slope reparameterization still holds. The deviations of the two partners have equal magnitude and opposite signs: \(x_{\mathrm{dev},1j} = -x_{\mathrm{dev},2j}\). Outcome means and deviations @@ -147,7 +158,7 @@ draw_dim_member_diagram() The resulting estimated fixed effects are a reparameterization of the APIM actor and partner effects [@Bolger2025Unified]. And just like the exchangeable APIM, the random-effects structure comprises a dyad-level intercept -and a dyad-level difference contrast indexed by `.dy_member_contrast_female_x_female_arbitrary`. +and a dyad-level difference contrast indexed by `.member_contrast_arbitrary`. In `glmmTMB`, with `dispformula = ~ 0`, these random effects represent the two members' Gaussian residual variance and covariance. @@ -168,14 +179,14 @@ dim_1 <- glmmTMB::glmmTMB( 1 + # Between-dyad effect - .dy_provided_support_dyad_mean_gmc + + .provided_support_dyad_mean_gmc + # Within-dyad effect - .dy_provided_support_within_dyad_dev + + .provided_support_within_dyad_dev + # Residual Gaussian covariance structure us(1 | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID) + us(0 + .member_contrast_arbitrary | coupleID) , dispformula = ~ 0 , family = gaussian() , data = cross_exchangeable_data @@ -265,13 +276,13 @@ apim_1 <- glmmTMB::glmmTMB( closeness ~ 1 + # Fixed effects APIM - .dy_provided_support_actor + .dy_provided_support_partner + + .provided_support_gmc_actor + .provided_support_gmc_partner + # Since both models are equivalent, the same random-effects structure # can be used. See the APIM vignette to learn how to back-transform # these blocks to a full actor-partner covariance matrix. us(1 | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID) + us(0 + .member_contrast_arbitrary | coupleID) , dispformula = ~ 0 , family = gaussian() , data = cross_exchangeable_data @@ -297,7 +308,17 @@ Once APIM estimates are present, one can easily obtain DIM estimates, and the other way around. Let $b_{\mathrm{actor}}$ and $b_{\mathrm{partner}}$ denote the APIM actor and partner slopes, and let $b_{\mathrm{mean}}$ and $b_{\mathrm{dev}}$ denote the DIM between-dyad and within-dyad slopes. -They relate as follows: +Complete pairs give the GMC APIM and DIM the same zero point, so the fixed +effects transform as follows. With raw APIM predictors, only the intercept +requires recentering. + +The shared intercept is + +$$ +b_{0,\mathrm{DIM}} = b_{0,\mathrm{APIM}}. +$$ + +The slopes relate as follows: $$ b_{\mathrm{mean}} = b_{\mathrm{actor}} + b_{\mathrm{partner}} @@ -330,14 +351,17 @@ In this example we can see that the transformations work: apim_coef <- glmmTMB::fixef(apim_1)$cond dim_coef <- glmmTMB::fixef(dim_1)$cond -b_actor <- apim_coef[[".dy_provided_support_actor"]] -b_partner <- apim_coef[[".dy_provided_support_partner"]] +b0_apim <- apim_coef[["(Intercept)"]] +b_actor <- apim_coef[[".provided_support_gmc_actor"]] +b_partner <- apim_coef[[".provided_support_gmc_partner"]] -b_mean <- dim_coef[[".dy_provided_support_dyad_mean_gmc"]] -b_dev <- dim_coef[[".dy_provided_support_within_dyad_dev"]] +b0_dim <- dim_coef[["(Intercept)"]] +b_mean <- dim_coef[[".provided_support_dyad_mean_gmc"]] +b_dev <- dim_coef[[".provided_support_within_dyad_dev"]] cat("From APIM model:\n", + " intercept: ", round(b0_apim, 3), "\n", " actor effect: ", round(b_actor, 3), "\n", " partner effect: ", round(b_partner, 3), "\n\n", @@ -346,15 +370,15 @@ cat("From APIM model:\n", " b_dev = b_actor - b_partner: ", round(b_actor - b_partner, 3), "\n\n", "From DIM model:\n", + " intercept: ", round(b0_dim, 3), "\n", " between-dyad effect: ", round(b_mean, 3), "\n", " within-dyad effect: ", round(b_dev, 3), "\n" ) ``` -The DIM and APIM intercepts are not expected to be equal because the DIM dyad -mean is grand-mean centered, whereas the APIM predictors retain their original -scale. +The DIM and APIM intercepts are equal up to numerical estimation tolerance +because both parameterizations now use the same grand-mean reference. ### Why Are These Models Equivalent? Exploring the Reparameterization @@ -455,20 +479,20 @@ dim_ILD <- glmmTMB::glmmTMB( diaryday + # Within-person DIM - .dy_provided_support_cwp_dyad_mean + - .dy_provided_support_cwp_within_dyad_dev + + .provided_support_cwp_dyad_mean + + .provided_support_cwp_within_dyad_dev + # Between-person DIM - .dy_provided_support_cbp_dyad_mean + - .dy_provided_support_cbp_within_dyad_dev + + .provided_support_cbp_dyad_mean + + .provided_support_cbp_within_dyad_dev + # Stable exchangeable dyad-level covariance us(1 | coupleID) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID) + + us(0 + .member_contrast_arbitrary | coupleID) + # Residual (same-day) exchangeable dyad-level covariance us(1 | coupleID:diaryday) + - us(0 + .dy_member_contrast_female_x_female_arbitrary | coupleID:diaryday) + us(0 + .member_contrast_arbitrary | coupleID:diaryday) , dispformula = ~ 0 , family = gaussian() @@ -553,7 +577,7 @@ coefficients, but still estimates the same model. Random slopes can be included in the DIM by adding the corresponding within-person effects to the stable dyad-level random-effect blocks. The shared block contains the DIM intercept, dyad-mean slope, and within-dyad -member-deviation slope. The `.dy_member_contrast_*` block contains their +member-deviation slope. The `.member_contrast_*` block contains their member-difference counterparts. Together, these blocks allow the two members to have different random slopes while preserving exchangeability. @@ -573,7 +597,7 @@ u_{\mathrm{partner},j} = \frac{u_{\mathrm{mean},j} - u_{\mathrm{dev},j}}{2}, $$ -and for the `.dy_member_contrast_*` block, marked by a tilde, +and for the `.member_contrast_*` block, marked by a tilde, $$ \widetilde{u}_{\mathrm{actor},j} @@ -583,9 +607,9 @@ $$ = \frac{\widetilde{u}_{\mathrm{mean},j} - \widetilde{u}_{\mathrm{dev},j}}{2}. $$ -The shared and `.dy_member_contrast_*` random intercepts remain unchanged. +The shared and `.member_contrast_*` random intercepts remain unchanged. -We now have the shared and `.dy_member_contrast_*` actor and partner effects which are then +We now have the shared and `.member_contrast_*` actor and partner effects which are then back-transformed into the complete and more readily interpretable member-specific actor-partner covariance matrix. This is described in the [exchangeable random-slope back-transformation in the APIM vignette](apim.html#exchangeable-random-slope-back-transformation). diff --git a/vignettes/dsm.Rmd b/vignettes/dsm.Rmd index 03ce8e43..28b572c6 100644 --- a/vignettes/dsm.Rmd +++ b/vignettes/dsm.Rmd @@ -50,6 +50,11 @@ A DSM requires an explicitly declared direction. This direction should be substantively meaningful when the directional coefficients are interpreted. Here, `c("female", "male")` defines every difference as female minus male. +Here $X_{\mathrm{female}}$ and $X_{\mathrm{male}}$ denote provided support +centered with the pooled mean from complete predictor pairs. +`prepare_dyad_data()` creates the corresponding DSM dyad-mean column; using the +original zero requires shifting it manually. + ```{r prepare-cross-dsm} cross_dsm_data <- dyadMLM::prepare_dyad_data( dyads_cross, @@ -68,19 +73,19 @@ cross_dsm_data <- dyadMLM::prepare_dyad_data( print(cross_dsm_data, n = 4) ``` -For predictor values $X_{\mathrm{female}}$ and $X_{\mathrm{male}}$, `dyadMLM` -then creates: +With this notation, `dyadMLM` creates the equivalent coordinates: -- `.dy_provided_support_dyad_mean_gmc` $= - \frac{X_{\mathrm{female}} + X_{\mathrm{male}}}{2} - \mu_X$ (with $\mu_X$ representing the sample grand - mean of the dyad-level predictor means) +- `.provided_support_dyad_mean_gmc` $= + \frac{X_{\mathrm{female}} + X_{\mathrm{male}}}{2}$ -- `.dy_provided_support_within_dyad_diff` $= X_{\mathrm{female}} - X_{\mathrm{male}}$ +- `.provided_support_within_dyad_diff` $= X_{\mathrm{female}} - X_{\mathrm{male}}$ -- `.dy_dsm_role_contrast` $= +0.5$ for female and $-0.5$ for male. +- `.dsm_role_contrast` $= +0.5$ for female and $-0.5$ for male. -The dyad mean and signed difference are repeated on both member rows. The -outcome remains unchanged and no transformation is needed. +The common centering shift cancels from the signed difference. Both predictor +scores are repeated on the member rows; the outcome remains unchanged. APIM GMC +uses all retained non-missing values, whereas DSM uses complete pairs, so their +constants may differ with one-sided missingness. ## Cross-Sectional Gaussian DSM @@ -109,22 +114,22 @@ dsm_model <- glmmTMB::glmmTMB( 1 + # Predictor level -> outcome level (a11) - .dy_provided_support_dyad_mean_gmc + + .provided_support_dyad_mean_gmc + # Predictor difference -> outcome level (a12) - .dy_provided_support_within_dyad_diff + + .provided_support_within_dyad_diff + # Outcome-difference intercept (a20) - .dy_dsm_role_contrast + + .dsm_role_contrast + # Predictor level -> outcome difference (a21) - .dy_provided_support_dyad_mean_gmc:.dy_dsm_role_contrast + + .provided_support_dyad_mean_gmc:.dsm_role_contrast + # Predictor difference -> outcome difference (a22) - .dy_provided_support_within_dyad_diff:.dy_dsm_role_contrast + + .provided_support_within_dyad_diff:.dsm_role_contrast + # Outcome-level and outcome-difference residual variances and their covariance - us(1 + .dy_dsm_role_contrast | coupleID), + us(1 + .dsm_role_contrast | coupleID), dispformula = ~ 0, family = gaussian(), data = cross_dsm_data @@ -144,12 +149,14 @@ decomposed in the same way: $$ X_{\mathrm{mean}} -= \frac{X_{\mathrm{female}} + X_{\mathrm{male}}}{2} - \mu_X, += \frac{X_{\mathrm{female}} + X_{\mathrm{male}}}{2}, \qquad -X_{\mathrm{diff}} = X_{\mathrm{female}} - X_{\mathrm{male}}, +X_{\mathrm{diff}} = X_{\mathrm{female}} - X_{\mathrm{male}}. $$ -where $\mu_X$ is the sample grand mean of the dyad-level predictor means. +Here the two member predictors already share the pooled grand-mean reference, +so $X_{\mathrm{mean}}$ is grand-mean centered and the common shift cancels from +$X_{\mathrm{diff}}$. The **outcomes** are also decomposed: @@ -275,6 +282,7 @@ cross_dsm_data_inverted <- dyadMLM::prepare_dyad_data( predictors = provided_support, # Request APIM columns too for comparison below. model_types = c("dsm", "apim"), + add_apim_gmc_predictors = TRUE, keep_compositions = "female-male", dsm_role_order = c("male", "female") ) @@ -283,12 +291,12 @@ cross_dsm_data_inverted <- dyadMLM::prepare_dyad_data( ```{r fit-cross-dsm-inverted, eval=has_glmmTMB} dsm_model_inverted <- glmmTMB::glmmTMB( closeness ~ - .dy_provided_support_dyad_mean_gmc + - .dy_provided_support_within_dyad_diff + - .dy_dsm_role_contrast + - .dy_provided_support_dyad_mean_gmc:.dy_dsm_role_contrast + - .dy_provided_support_within_dyad_diff:.dy_dsm_role_contrast + - us(1 + .dy_dsm_role_contrast | coupleID), + .provided_support_dyad_mean_gmc + + .provided_support_within_dyad_diff + + .dsm_role_contrast + + .provided_support_dyad_mean_gmc:.dsm_role_contrast + + .provided_support_within_dyad_diff:.dsm_role_contrast + + us(1 + .dsm_role_contrast | coupleID), dispformula = ~ 0, family = gaussian(), data = cross_dsm_data_inverted @@ -311,21 +319,21 @@ knitr::kable( The two models have identical fitted values and model fit: -- `.dy_provided_support_within_dyad_diff` reverses because the predictor difference +- `.provided_support_within_dyad_diff` reverses because the predictor difference reverses. -- `.dy_dsm_role_contrast` reverses because the represented outcome difference +- `.dsm_role_contrast` reverses because the represented outcome difference reverses. -- `.dy_provided_support_dyad_mean_gmc:.dy_dsm_role_contrast` reverses because only +- `.provided_support_dyad_mean_gmc:.dsm_role_contrast` reverses because only the outcome difference reverses. -- `.dy_provided_support_within_dyad_diff:.dy_dsm_role_contrast` remains unchanged +- `.provided_support_within_dyad_diff:.dsm_role_contrast` remains unchanged because both differences reverse. -The intercept and `.dy_provided_support_dyad_mean_gmc` also remain unchanged. For +The intercept and `.provided_support_dyad_mean_gmc` also remain unchanged. For the random effects, the variances of `(Intercept)` and -`.dy_dsm_role_contrast` remain unchanged, whereas their covariance reverses +`.dsm_role_contrast` remain unchanged, whereas their covariance reverses sign. ## Relationship to the APIM and DIM @@ -341,21 +349,21 @@ apim_model <- glmmTMB::glmmTMB( closeness ~ # Role-specific intercepts 0 + - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + + .is_female + + .is_male + # Role-specific actor effects - .dy_is_female_x_male_female:.dy_provided_support_actor + - .dy_is_female_x_male_male:.dy_provided_support_actor + + .is_female:.provided_support_gmc_actor + + .is_male:.provided_support_gmc_actor + # Role-specific partner effects - .dy_is_female_x_male_female:.dy_provided_support_partner + - .dy_is_female_x_male_male:.dy_provided_support_partner + + .is_female:.provided_support_gmc_partner + + .is_male:.provided_support_gmc_partner + # Role-specific Gaussian residual covariance structure us(0 + - .dy_is_female_x_male_female + - .dy_is_female_x_male_male + .is_female + + .is_male | coupleID), dispformula = ~ 0, family = gaussian(), @@ -423,19 +431,18 @@ a_{22} \end{aligned} $$ -The APIM predictors retain their original scale, whereas the DSM predictor -level is grand-mean centered. Keeping the raw APIM predictors on their original -scale preserves their reference values; the centering difference is handled -explicitly in the intercept transformation. If $\mu_X$ is the grand mean -subtracted from the DSM predictor level, the intercepts transform as +With complete pairs, the GMC APIM and DSM share a zero point, so the intercepts +transform as $$ -a_{10} -= \frac{b_{0,\mathrm{female}} + b_{0,\mathrm{male}}}{2} + \mu_X a_{11}, +a_{10} = \frac{b_{0,\mathrm{female}} + b_{0,\mathrm{male}}}{2}, \qquad -a_{20} = b_{0,\mathrm{female}} - b_{0,\mathrm{male}} + \mu_X a_{21}. +a_{20} = b_{0,\mathrm{female}} - b_{0,\mathrm{male}}. $$ +Raw APIM predictors leave the slope transformations unchanged but require +intercept recentering. + For the reverse slope transformation, first recover the role-specific actor-plus-partner and actor-minus-partner combinations: @@ -467,13 +474,11 @@ $$ The intercepts transform back as $$ -b_{0,\mathrm{female}} = a_{10} + \frac{a_{20}}{2} -- \mu_X\left(a_{11} + \frac{a_{21}}{2}\right), +b_{0,\mathrm{female}} = a_{10} + \frac{a_{20}}{2}, $$ $$ -b_{0,\mathrm{male}} = a_{10} - \frac{a_{20}}{2} -- \mu_X\left(a_{11} - \frac{a_{21}}{2}\right). +b_{0,\mathrm{male}} = a_{10} - \frac{a_{20}}{2}. $$ The following comparison applies the APIM-to-DSM transformation to all six @@ -483,28 +488,21 @@ fixed effects: apim_coef <- glmmTMB::fixef(apim_model)$cond dsm_coef <- glmmTMB::fixef(dsm_model)$cond -b0_female <- apim_coef[[".dy_is_female_x_male_female"]] -b0_male <- apim_coef[[".dy_is_female_x_male_male"]] +b0_female <- apim_coef[[".is_female"]] +b0_male <- apim_coef[[".is_male"]] b_actor_female <- apim_coef[[ - ".dy_is_female_x_male_female:.dy_provided_support_actor" + ".is_female:.provided_support_gmc_actor" ]] b_actor_male <- apim_coef[[ - ".dy_is_female_x_male_male:.dy_provided_support_actor" + ".is_male:.provided_support_gmc_actor" ]] b_partner_female <- apim_coef[[ - ".dy_is_female_x_male_female:.dy_provided_support_partner" + ".is_female:.provided_support_gmc_partner" ]] b_partner_male <- apim_coef[[ - ".dy_is_female_x_male_male:.dy_provided_support_partner" + ".is_male:.provided_support_gmc_partner" ]] -mu_X <- mean( - (cross_dsm_data_inverted$.dy_provided_support_actor + - cross_dsm_data_inverted$.dy_provided_support_partner) / 2 - - cross_dsm_data_inverted$.dy_provided_support_dyad_mean_gmc, - na.rm = TRUE -) - b_sum_female <- b_actor_female + b_partner_female b_sum_male <- b_actor_male + b_partner_male b_difference_female <- b_actor_female - b_partner_female @@ -516,23 +514,23 @@ a12_from_apim <- (b_difference_female - b_difference_male) / 4 a22_from_apim <- (b_difference_female + b_difference_male) / 2 apim_to_dsm <- c( - a10 = (b0_female + b0_male) / 2 + mu_X * a11_from_apim, + a10 = (b0_female + b0_male) / 2, a11 = a11_from_apim, a12 = a12_from_apim, - a20 = b0_female - b0_male + mu_X * a21_from_apim, + a20 = b0_female - b0_male, a21 = a21_from_apim, a22 = a22_from_apim ) a10_dsm <- dsm_coef[["(Intercept)"]] -a11_dsm <- dsm_coef[[".dy_provided_support_dyad_mean_gmc"]] -a12_dsm <- dsm_coef[[".dy_provided_support_within_dyad_diff"]] -a20_dsm <- dsm_coef[[".dy_dsm_role_contrast"]] +a11_dsm <- dsm_coef[[".provided_support_dyad_mean_gmc"]] +a12_dsm <- dsm_coef[[".provided_support_within_dyad_diff"]] +a20_dsm <- dsm_coef[[".dsm_role_contrast"]] a21_dsm <- dsm_coef[[ - ".dy_provided_support_dyad_mean_gmc:.dy_dsm_role_contrast" + ".provided_support_dyad_mean_gmc:.dsm_role_contrast" ]] a22_dsm <- dsm_coef[[ - ".dy_provided_support_within_dyad_diff:.dy_dsm_role_contrast" + ".provided_support_within_dyad_diff:.dsm_role_contrast" ]] knitr::kable( @@ -550,10 +548,9 @@ knitr::kable( check.names = FALSE ), align = c("l", "r", "r"), - caption = paste0( - "APIM-to-DSM fixed-effect transformation (centering constant = ", - round(mu_X, 3), - ")." + caption = paste( + "APIM-to-DSM fixed-effect transformation with pooled", + "grand-mean-centered actor and partner predictors." ) ) ``` @@ -657,34 +654,34 @@ dsm_ILD <- glmmTMB::glmmTMB( diaryday + # Within-person predictor level -> outcome level - .dy_provided_support_cwp_dyad_mean + + .provided_support_cwp_dyad_mean + # Within-person predictor difference -> outcome level - .dy_provided_support_cwp_within_dyad_diff + + .provided_support_cwp_within_dyad_diff + # Between-person predictor level -> outcome level - .dy_provided_support_cbp_dyad_mean + + .provided_support_cbp_dyad_mean + # Between-person predictor difference -> outcome level - .dy_provided_support_cbp_within_dyad_diff + + .provided_support_cbp_within_dyad_diff + # Outcome-difference intercept and linear time trend - .dy_dsm_role_contrast + - diaryday:.dy_dsm_role_contrast + + .dsm_role_contrast + + diaryday:.dsm_role_contrast + # Within-person predictor level and difference -> outcome difference - .dy_provided_support_cwp_dyad_mean:.dy_dsm_role_contrast + - .dy_provided_support_cwp_within_dyad_diff:.dy_dsm_role_contrast + + .provided_support_cwp_dyad_mean:.dsm_role_contrast + + .provided_support_cwp_within_dyad_diff:.dsm_role_contrast + # Between-person predictor level and difference -> outcome difference - .dy_provided_support_cbp_dyad_mean:.dy_dsm_role_contrast + - .dy_provided_support_cbp_within_dyad_diff:.dy_dsm_role_contrast + + .provided_support_cbp_dyad_mean:.dsm_role_contrast + + .provided_support_cbp_within_dyad_diff:.dsm_role_contrast + # Stable outcome-level and outcome-difference covariance - us(1 + .dy_dsm_role_contrast | coupleID) + + us(1 + .dsm_role_contrast | coupleID) + # Same-day outcome-level and outcome-difference covariance - us(1 + .dy_dsm_role_contrast | coupleID:diaryday), + us(1 + .dsm_role_contrast | coupleID:diaryday), dispformula = ~ 0, family = gaussian(), data = ild_dsm_data diff --git a/vignettes/getting-started.Rmd b/vignettes/getting-started.Rmd index 9d184c8c..1a18d089 100644 --- a/vignettes/getting-started.Rmd +++ b/vignettes/getting-started.Rmd @@ -25,17 +25,14 @@ library(dyadMLM) ## Installation -You can install the released version of `dyadMLM` from CRAN with: - -```{r installation-cran, eval=FALSE} -install.packages("dyadMLM") -``` - -You can install the development version from GitHub with: +You can install the development version with: ```{r installation, eval=FALSE} -# install.packages("pak") -pak::pak("Pascal-Kueng/dyadMLM") +install.packages("dyadMLM", repos = c( + "https://pascal-kueng.r-universe.dev", + "https://cloud.r-project.org" + ) +) ``` ## About this Vignette @@ -140,6 +137,7 @@ cross_distinguishable_data <- dyadMLM::prepare_dyad_data( # and a model type to generate the columns needed for that model type. predictors = provided_support, model_types = "apim", + add_apim_gmc_predictors = TRUE, # All three observed compositions in `dyads_cross` are detected and retained by # default. This example focuses on `female-male` dyads, so we restrict the # analysis here. @@ -150,10 +148,12 @@ print(cross_distinguishable_data, n = 4) ``` -The function retained and recognized 120 -female-male dyads and created APIM-relevant variables -[@kennyPartnerEffectsRelationship1999]. These generated `.dy_*` columns can be -used directly in model formulas. +The function retained 120 female-male dyads and created APIM variables +[@kennyPartnerEffectsRelationship1999]. `add_apim_gmc_predictors = TRUE` keeps +the raw columns and adds `.provided_support_gmc` plus actor and partner variants, +centered over all retained non-missing source values. Mixed non-numeric +predictors remain raw and trigger one warning. With an intercept, use either the +raw or GMC actor-partner pair, not both. For fitted APIM examples using these columns, see the [Actor-Partner Interdependence Model vignette](apim.html). @@ -177,7 +177,7 @@ print(cross_exchangeable_data, n = 4) ``` -The generated `.dy_member_contrast_female_x_female_arbitrary` contrast assigns `-1` +The generated `.member_contrast_arbitrary` contrast assigns `-1` and `1` to the two members of each exchangeable dyad [@delrosarioPracticalGuideSpecifying2025]. Its direction is arbitrary, and `seed` makes the assignment reproducible. @@ -249,6 +249,9 @@ cross_dsm_data <- dyadMLM::prepare_dyad_data( print(cross_dsm_data, n = 4) ``` +APIM GMC uses all retained non-missing values; DIM and DSM center complete-pair +dyad means. The constants may differ with one-sided missingness. + ## Intensive longitudinal dyadic data @@ -286,6 +289,10 @@ is controlled by `temporal_decomposition`. The default `"auto"` setting selects `"2l"` for this longitudinal setup and retains raw actor and partner columns alongside both components. +`add_apim_gmc_predictors = TRUE` requires resolved +`temporal_decomposition = "none"`. In longitudinal data, its mean is +observation-weighted, and lagged GMC columns use the same mean. + Note that observed person means used to construct the between-person (`cbp`) predictors can be unreliable when each member contributes few occasions, which can bias between-person estimates [@gottfredsonStraightforwardApproachCoping2019]. @@ -350,7 +357,7 @@ print(mixed_cross_data, n = 4) Note that when role compositions are available, each exchangeable composition receives its own difference contrast, such as -`.dy_member_contrast_female_x_female_arbitrary`, which is `0` for all other compositions +`.member_contrast_female_x_female_arbitrary`, which is `0` for all other compositions [@delrosarioPracticalGuideSpecifying2025]. We can use this data to model these dyad types as separate or in the same model. @@ -406,7 +413,7 @@ pool selected exchangeable dyad compositions and analyze them as if they were on Pooling can impose equality constraints among compositions. After fitting nested pooled and unpooled models to the same observations, these constraints can be tested with -[`dyadMLM::compare_nested_glmmTMB_models()`](https://pascal-kueng.github.io/dyadMLM/reference/compare_nested_glmmTMB_models.html); see +`dyadMLM::compare_nested_models()`; see [Testing distinguishability in the APIM vignette](apim.html#testing-distinguishability) for the model-comparison workflow. diff --git a/vignettes/references.bib b/vignettes/references.bib index 7276d760..adfd8b78 100644 --- a/vignettes/references.bib +++ b/vignettes/references.bib @@ -49,6 +49,19 @@ @article{hoehenerEffectivenessSmartphoneDyadic2026 langid = {english} } +@article{ajzenTheoryPlannedBehavior1991, + title = {The Theory of Planned Behavior}, + author = {Ajzen, Icek}, + date = {1991-12}, + journaltitle = {Organizational Behavior and Human Decision Processes}, + volume = {50}, + number = {2}, + pages = {179--211}, + doi = {10.1016/0749-5978(91)90020-T}, + url = {https://doi.org/10.1016/0749-5978(91)90020-T}, + langid = {english} +} + @article{ledermannAnalyzingDyadicData2017, title = {Analyzing Dyadic Data with Multilevel Modeling versus Structural Equation Modeling: {{A}} Tale of Two Methods.}, shorttitle = {Analyzing Dyadic Data with Multilevel Modeling versus Structural Equation Modeling}, @@ -66,6 +79,32 @@ @article{ledermannAnalyzingDyadicData2017 langid = {english} } +@article{hughesAccountingMissingData2019, + title = {Accounting for Missing Data in Statistical Analyses: Multiple Imputation Is Not Always the Answer}, + author = {Hughes, Rachael A. and Heron, Jon and Sterne, Jonathan A. C. and Tilling, Kate}, + date = {2019}, + journaltitle = {International Journal of Epidemiology}, + volume = {48}, + number = {4}, + pages = {1294--1304}, + doi = {10.1093/ije/dyz032}, + url = {https://doi.org/10.1093/ije/dyz032}, + langid = {english} +} + +@article{grundMultipleImputationMissing2018, + title = {Multiple Imputation of Missing Data for Multilevel Models: Simulations and Recommendations}, + author = {Grund, Simon and Lüdtke, Oliver and Robitzsch, Alexander}, + date = {2018}, + journaltitle = {Organizational Research Methods}, + volume = {21}, + number = {1}, + pages = {111--149}, + doi = {10.1177/1094428117703686}, + url = {https://doi.org/10.1177/1094428117703686}, + langid = {english} +} + @article{ledermannMediationDyadicData2009, title = {Mediation in Dyadic Data at the Level of the Dyads: {{A}} Structural Equation Modeling Approach}, @@ -244,6 +283,108 @@ @article{kennyAccuracyBiasPerception2001 } +@article{ledermannAssessingMediationDyadic2011, + title = {Assessing Mediation in Dyadic Data Using the Actor--Partner Interdependence Model}, + author = {Ledermann, Thomas and Macho, Siegfried and Kenny, David A.}, + date = {2011}, + journaltitle = {Structural Equation Modeling: A Multidisciplinary Journal}, + shortjournal = {Structural Equation Modeling}, + volume = {18}, + number = {4}, + pages = {595--612}, + doi = {10.1080/10705511.2011.607099}, + url = {https://doi.org/10.1080/10705511.2011.607099}, + langid = {english} +} + + +@article{schonbrodtTestingSimilarityEffects2018, + title = {Testing Similarity Effects with Dyadic Response Surface Analysis}, + author = {Schönbrodt, Felix D. and Humberg, Sarah and Nestler, Steffen}, + date = {2018}, + journaltitle = {European Journal of Personality}, + shortjournal = {European Journal of Personality}, + volume = {32}, + number = {6}, + pages = {627--641}, + doi = {10.1002/per.2169}, + url = {https://doi.org/10.1002/per.2169}, + langid = {english} +} + + +@article{driverContinuousTimeStructural2017, + title = {Continuous Time Structural Equation Modeling with {R} Package {ctsem}}, + author = {Driver, Charles C. and Oud, Johan H. L. and Voelkle, Manuel C.}, + date = {2017}, + journaltitle = {Journal of Statistical Software}, + volume = {77}, + number = {5}, + pages = {1--35}, + doi = {10.18637/jss.v077.i05}, + url = {https://doi.org/10.18637/jss.v077.i05}, + langid = {english} +} + + +@incollection{kennySocialRelationsModel1984, + title = {The Social Relations Model}, + author = {Kenny, David A. and La Voie, Lawrence}, + editor = {Berkowitz, Leonard}, + date = {1984}, + booktitle = {Advances in Experimental Social Psychology}, + volume = {18}, + pages = {141--182}, + publisher = {Academic Press}, + doi = {10.1016/S0065-2601(08)60144-6}, + url = {https://doi.org/10.1016/S0065-2601(08)60144-6}, + langid = {english} +} + +@article{nestlerResponseSurfaceAnalysis2019, + title = {Response Surface Analysis with Multilevel Data: {{Illustration}} for the Case of Congruence Hypotheses}, + author = {Nestler, Steffen and Humberg, Sarah and Schönbrodt, Felix D.}, + date = {2019-06}, + journaltitle = {Psychological Methods}, + volume = {24}, + number = {3}, + pages = {291--308}, + doi = {10.1037/met0000199}, + url = {https://doi.org/10.1037/met0000199}, + langid = {english} +} + + +@article{hollandExponentialFamilyDirected1981, + title = {An Exponential Family of Probability Distributions for Directed Graphs}, + author = {Holland, Paul W. and Leinhardt, Samuel}, + date = {1981}, + journaltitle = {Journal of the American Statistical Association}, + shortjournal = {Journal of the American Statistical Association}, + volume = {76}, + number = {373}, + pages = {33--50}, + doi = {10.1080/01621459.1981.10477598}, + url = {https://doi.org/10.1080/01621459.1981.10477598}, + langid = {english} +} + + +@article{snijdersStatisticalEvaluationNetwork2001, + title = {The Statistical Evaluation of Social Network Dynamics}, + author = {Snijders, Tom A. B.}, + date = {2001}, + journaltitle = {Sociological Methodology}, + shortjournal = {Sociological Methodology}, + volume = {31}, + number = {1}, + pages = {361--395}, + doi = {10.1111/0081-1750.00099}, + url = {https://doi.org/10.1111/0081-1750.00099}, + langid = {english} +} + + @article{delrosarioPracticalGuideSpecifying2025, title = {A {{Practical Guide}} to {{Specifying Random Effects}} in {{Longitudinal Dyadic Multilevel Modeling}}}, author = {family=Rosario, given=Kareena S., prefix=del, useprefix=true and West, Tessa V.}, @@ -289,6 +430,19 @@ @article{hamakerCritiqueCrossLagged2015 langid = {english} } +@article{mulderThreeExtensions2021, + title = {Three Extensions of the Random Intercept Cross-Lagged Panel Model}, + author = {Mulder, Jeroen D. and Hamaker, Ellen L.}, + date = {2021}, + journaltitle = {Structural Equation Modeling: A Multidisciplinary Journal}, + volume = {28}, + number = {4}, + pages = {638--648}, + doi = {10.1080/10705511.2020.1784738}, + url = {https://doi.org/10.1080/10705511.2020.1784738}, + langid = {english} +} + @article{stadlerHowCompanionshipRelated2023, title = {How Is Companionship Related to Romantic Partners' Affect, Relationship Satisfaction, and Health Behavior? {{Using}} a Longitudinal Dyadic Score Model to Understand Daily and Couple-Level Effects of a Dyadic Predictor}, @@ -397,6 +551,19 @@ @article{gistelinckMultilevelAutoregressiveSmall2021 langid = {english} } +@article{gistelinckIndistinguishabilityTests2018, + title = {Indistinguishability Tests in the Actor--Partner Interdependence Model}, + author = {Gistelinck, Fien and Loeys, Tom and Decuyper, Mieke and Dewitte, Marieke}, + date = {2018}, + journaltitle = {British Journal of Mathematical and Statistical Psychology}, + volume = {71}, + number = {3}, + pages = {472--498}, + doi = {10.1111/bmsp.12129}, + url = {https://doi.org/10.1111/bmsp.12129}, + langid = {english} +} + @article{gottfredsonStraightforwardApproachCoping2019, title = {A Straightforward Approach for Coping With Unreliability of Person Means When Parsing Within-Person and Between-Person Effects in Longitudinal Studies}, author = {Gottfredson, Nisha C.}, @@ -457,6 +624,19 @@ @article{scholzBeyondBehaviouralIntentions2008 doi = {10.1348/135910707X216062} } +@article{sniehottaBridgingIntentionBehaviour2005, + title = {Bridging the Intention--Behaviour Gap: Planning, Self-Efficacy, and Action Control in the Adoption and Maintenance of Physical Exercise}, + author = {Sniehotta, Falko F. and Scholz, Urte and Schwarzer, Ralf}, + date = {2005}, + journaltitle = {Psychology \& Health}, + volume = {20}, + number = {2}, + pages = {143--160}, + doi = {10.1080/08870440512331317670}, + url = {https://doi.org/10.1080/08870440512331317670}, + langid = {english} +} + @article{bolgerInvisibleSupportAdjustment2000, title = {Invisible Support and Adjustment to Stress}, author = {Bolger, Niall and Zuckerman, Adam and Kessler, Ronald C.}, @@ -478,3 +658,257 @@ @article{amireaultGodinShephardQuestionnaire2015 pages = {604--622}, doi = {10.2466/03.27.PMS.120v19x7} } + +@online{lavaanMultilevelSEM, + title = {Multilevel {SEM}}, + author = {{lavaan project}}, + url = {https://lavaan.ugent.be/tutorial/multilevel.html}, + urldate = {2026-07-23} +} + +@online{lavaanRandomSlopeSyntax, + title = {lavaan Model Syntax: Random Slopes (Two-Level Models)}, + author = {{lavaan project}}, + note = {lavaan 0.7-2 reference manual}, + url = {https://stat.ethz.ch/CRAN/web/packages/lavaan/refman/lavaan.html}, + urldate = {2026-07-23} +} + +@online{blavaanTwoLevelSEM, + title = {Two-Level {SEM}}, + author = {Merkle, Edgar C. and Rosseel, Yves and Goodrich, Ben}, + url = {https://blavaan.org/articles/multilevel.html}, + urldate = {2026-07-23} +} + +@manual{koslowskiMlts2025, + title = {mlts: Multilevel Latent Time Series Models with {R} and {Stan}}, + author = {Koslowski, Kenneth and Münch, Fabian and Koch, Tobias and Holtmann, Jana}, + date = {2025}, + note = {R package version 2.0.1}, + url = {https://CRAN.R-project.org/package=mlts} +} + +@online{kristensenCovarianceStructuresGlmmTMB2023, + title = {Covariance Structures with {glmmTMB}}, + author = {Kristensen, Kasper and McGillycuddy, Maeve}, + date = {2023-10-14}, + url = {https://glmmtmb.github.io/glmmTMB/articles/covstruct.html}, + urldate = {2026-07-23} +} + +@online{buerknerAutocorrelationStructuresBrms, + title = {Autocorrelation Structures}, + author = {Bürkner, Paul-Christian}, + note = {brms 2.23.1}, + url = {https://paulbuerkner.com/brms/reference/autocor-terms.html}, + urldate = {2026-07-23} +} + +@manual{sasInstituteMixedProcedure, + title = {{SAS/STAT} 15.4 User's Guide: The {MIXED} Procedure}, + author = {{SAS Institute Inc.}}, + organization = {SAS Institute Inc.}, + url = {https://go.documentation.sas.com/api/collections/pgmsascdc/9.4_3.5/docsets/statug/content/mixed.pdf}, + urldate = {2026-07-23} +} + +@online{ibmCovarianceStructureList, + title = {Covariance Structure List ({MIXED} Command)}, + author = {{IBM Corp.}}, + note = {IBM SPSS Statistics 32.0.0}, + url = {https://www.ibm.com/docs/en/spss-statistics/32.0.0?topic=mixed-covariance-structure-list-command}, + urldate = {2026-07-23} +} + +@article{stasGivingDyadicData2018, + title = {Giving Dyadic Data Analysis Away: {{A}} User-Friendly App for Actor--Partner Interdependence Models}, + author = {Stas, Lara and Kenny, David A. and Mayer, Axel and Loeys, Tom}, + date = {2018-03}, + journaltitle = {Personal Relationships}, + volume = {25}, + number = {1}, + pages = {103--119}, + issn = {1350-4126}, + doi = {10.1111/pere.12230}, + url = {https://doi.org/10.1111/pere.12230}, + langid = {english} +} + +@article{perryGraphicMethodsInterpreting2017, + title = {Graphic Methods for Interpreting Longitudinal Dyadic Patterns from Repeated-Measures Actor--Partner Interdependence Models}, + author = {Perry, Nicholas S. and Baucom, Katherine J. W. and Bourne, Stacia and Butner, Jonathan and Crenshaw, Alexander O. and Hogan, Jasara N. and Imel, Zac E. and Wiltshire, Travis J. and Baucom, Brian R. W.}, + date = {2017-08}, + journaltitle = {Journal of Family Psychology}, + volume = {31}, + number = {5}, + pages = {592--603}, + issn = {0893-3200}, + doi = {10.1037/fam0000293}, + url = {https://doi.org/10.1037/fam0000293}, + langid = {english} +} + +@article{revolPreprocessingExperienceSampling2024, + title = {Preprocessing Experience-Sampling-Method Data: {{A}} Step-by-Step Framework, Tutorial Website, {R} Package, and Reporting Templates}, + author = {Revol, Jordan and Carlier, Chiara and Lafit, Ginette and Verhees, Martine and Sels, Laura and Ceulemans, Eva}, + date = {2024-10}, + journaltitle = {Advances in Methods and Practices in Psychological Science}, + volume = {7}, + number = {4}, + pages = {25152459241256609}, + doi = {10.1177/25152459241256609}, + url = {https://doi.org/10.1177/25152459241256609}, + langid = {english} +} + +@article{mohammadzadehYazdBeyondIndividual2026, + title = {Beyond the Individual: {{A}} 25-Year Systematic Review of the Actor--Partner Interdependence Model in Longitudinal Dyadic Research Across Disciplines and Contexts}, + author = {Mohammadzadeh Yazd, Fereshteh and Foong, Hui Foh and Ibrahim, Rahimah and Kunasekaran, Puvaneswaran}, + date = {2026-04-15}, + journaltitle = {Journal of Social and Personal Relationships}, + pages = {02654075261443593}, + doi = {10.1177/02654075261443593}, + url = {https://doi.org/10.1177/02654075261443593}, + langid = {english} +} + +@article{xiangInfluenceDiagnosticsGeneralized2002, + title = {Influence Diagnostics for Generalized Linear Mixed Models: Applications to Clustered Data}, + author = {Xiang, Liming and Tse, Siu-Keung and Lee, Andy H.}, + date = {2002-10}, + journaltitle = {Computational Statistics \& Data Analysis}, + volume = {40}, + number = {4}, + pages = {759--774}, + doi = {10.1016/S0167-9473(02)00075-0}, + url = {https://doi.org/10.1016/S0167-9473(02)00075-0}, + langid = {english} +} + +@article{brooksGlmmTMBBalancesSpeed2017, + title = {{glmmTMB} Balances Speed and Flexibility Among Packages for Zero-Inflated Generalized Linear Mixed Modeling}, + author = {Brooks, Mollie E. and Kristensen, Kasper and {van Benthem}, Koen J. and Magnusson, Arni and Berg, Casper W. and Nielsen, Anders and Skaug, Hans J. and Mächler, Martin and Bolker, Benjamin M.}, + date = {2017}, + journaltitle = {The R Journal}, + volume = {9}, + number = {2}, + pages = {378--400}, + doi = {10.32614/RJ-2017-066}, + url = {https://doi.org/10.32614/RJ-2017-066}, + langid = {english} +} + +@manual{hartigDHARMaResidualDiagnostics2026, + title = {{{DHARMa}}: Residual Diagnostics for Hierarchical (Multi-Level / Mixed) Regression Models}, + author = {Hartig, Florian}, + date = {2026}, + note = {R package version 0.5.0}, + doi = {10.32614/CRAN.package.DHARMa}, + url = {https://CRAN.R-project.org/package=DHARMa} +} + +@article{ledermannToolboxProgramsRestructure2015, + title = {A Toolbox with Programs to Restructure and Describe Dyadic Data}, + author = {Ledermann, Thomas and Kenny, David A.}, + date = {2015-12}, + journaltitle = {Journal of Social and Personal Relationships}, + volume = {32}, + number = {8}, + pages = {997--1011}, + doi = {10.1177/0265407514555273}, + url = {https://doi.org/10.1177/0265407514555273}, + langid = {english} +} + +@article{hamakerCuriousCaseCrossSectional2024, + title = {The Curious Case of the Cross-Sectional Correlation}, + author = {Hamaker, Ellen L.}, + date = {2024}, + journaltitle = {Multivariate Behavioral Research}, + volume = {59}, + number = {6}, + pages = {1111--1122}, + doi = {10.1080/00273171.2022.2155930}, + url = {https://doi.org/10.1080/00273171.2022.2155930}, + langid = {english} +} + +@manual{kuengWbCorrBivariateWithin2026, + title = {{{wbCorr}}: Bivariate Within- and Between-Cluster Correlations}, + author = {Küng, Pascal}, + date = {2026}, + organization = {University of Zürich}, + note = {R package version 0.3.2}, + doi = {10.32614/CRAN.package.wbCorr}, + url = {https://CRAN.R-project.org/package=wbCorr} +} + +@article{geldhofReliabilityEstimationMultilevel2014, + title = {Reliability Estimation in a Multilevel Confirmatory Factor Analysis Framework}, + author = {Geldhof, G. John and Preacher, Kristopher J. and Zyphur, Michael J.}, + date = {2014-03}, + journaltitle = {Psychological Methods}, + volume = {19}, + number = {1}, + pages = {72--91}, + doi = {10.1037/a0032138}, + url = {https://doi.org/10.1037/a0032138}, + langid = {english} +} + +@article{laiCompositeReliabilityMultilevel2021, + title = {Composite Reliability of Multilevel Data: It's About Observed Scores and Construct Meanings}, + author = {Lai, Mark H. C.}, + date = {2021}, + journaltitle = {Psychological Methods}, + volume = {26}, + number = {1}, + pages = {90--102}, + doi = {10.1037/met0000287}, + url = {https://doi.org/10.1037/met0000287}, + langid = {english} +} + +@manual{wileyMultilevelTools2025, + title = {{{multilevelTools}}: Multilevel and Mixed Effects Model Diagnostics and Effect Sizes}, + author = {Wiley, Joshua F.}, + date = {2025}, + note = {R package version 0.2.1}, + doi = {10.32614/CRAN.package.multilevelTools}, + url = {https://CRAN.R-project.org/package=multilevelTools} +} + +@article{lafitPowerLAPIMApplication2022, + title = {{{PowerLAPIM}}: An Application to Conduct Power Analysis for Linear and Quadratic Longitudinal Actor--Partner Interdependence Models in Intensive Longitudinal Dyadic Designs}, + author = {Lafit, Ginette and Sels, Laura and Adolf, Janne K. and Loeys, Tom and Ceulemans, Eva}, + date = {2022-10}, + journaltitle = {Journal of Social and Personal Relationships}, + volume = {39}, + number = {10}, + pages = {3085--3115}, + doi = {10.1177/02654075221080128}, + url = {https://doi.org/10.1177/02654075221080128}, + langid = {english} +} + +@article{foxCrossValidatingRegressionModels2026, + title = {{{cv}}: An {{R}} Package for Cross-Validating Regression Models}, + author = {Fox, John and Monette, Georges}, + date = {2026}, + journaltitle = {Journal of Statistical Software}, + volume = {116}, + number = {8}, + pages = {1--41}, + doi = {10.18637/jss.v116.i08}, + url = {https://doi.org/10.18637/jss.v116.i08}, + langid = {english} +} + +@online{glmmTMBTroubleshooting2026, + title = {Troubleshooting with {{glmmTMB}}}, + author = {{glmmTMB Development Team}}, + date = {2026}, + url = {https://glmmtmb.github.io/glmmTMB/articles/troubleshooting.html}, + urldate = {2026-07-24} +}