Study 2 Pilot 2
Samantha Grayson
2025-08-30
Load packages
library(lavaan)## This is lavaan 0.6-18
## lavaan is FREE software! Please report any bugs.library(tidyverse)## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.5
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ ggplot2 3.5.1 ✔ tibble 3.2.1
## ✔ lubridate 1.9.4 ✔ tidyr 1.3.1
## ✔ purrr 1.0.4## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorsLoad data
data <- read.csv("~/Google drive/My Drive/YEAR 2/PROJECTS/DEREK/Status Distribution/Studies/Study 2: Status Affordance/raw_study2_pilotdata2_8.29.25.csv")Exclusions
data <- data %>%
slice(-c(1:2)) %>%
filter(attn_bots != "14285733") %>%
filter(attn == 24) %>%
unite(geolocation, LocationLatitude, LocationLongitude) %>%
group_by(geolocation) %>%
mutate(geo_frequency = n()) %>%
filter(geo_frequency < 3) %>%
ungroup()Data cleaning
Gather and clean numeric data
df_numeric <- data %>%
select(c(ResponseId, dist_1R:attr_10, affordance1_1:affordance1_3, affordance2_1:affordance2_3, affordance3_1:affordance3_3, SZSB_1:SZSB_8R, sdo_1:sdo_8R, need.for.status_1:need.for.status_8, dom_1:prest_9R, fv_inclusivity)) %>%
mutate(across(-ResponseId, as.numeric))df_numeric <- df_numeric %>%
mutate(across(ends_with("R"), ~ 8 - ., .names = "{.col}_Recoded")) Create average scores
df_numeric <- df_numeric %>%
mutate(
status_expansion_belief = rowMeans(select(.,
dist_1R_Recoded,
dist_2R_Recoded,
dist_5R_Recoded,
dist_14,
dist_15,
dist_16,
attr_3,
attr_4,
attr_5,
attr_6,
attr_8,
attr_10),
na.rm = TRUE)
)df_numeric <- df_numeric %>%
mutate(
dist_avg = rowMeans(select(.,
dist_1R_Recoded,
dist_2R_Recoded,
dist_5R_Recoded,
dist_14,
dist_15,
dist_16),
na.rm = TRUE)
)df_numeric <- df_numeric %>%
mutate(
attribute_avg = rowMeans(select(.,
attr_3,
attr_4,
attr_5,
attr_6,
attr_8,
attr_10
), na.rm = TRUE)
)df_numeric <- df_numeric %>%
mutate(
descriptive_avg = rowMeans(select(.,
dist_1R_Recoded,
dist_2R_Recoded,
dist_5R_Recoded,
attr_3,
attr_4,
attr_5),
na.rm = TRUE)
)df_numeric <- df_numeric %>%
mutate(
prescriptive_avg = rowMeans(select(.,
dist_14,
dist_15,
dist_16,
attr_6,
attr_8,
attr_10),
na.rm = TRUE)
)df_numeric <- df_numeric %>%
mutate(
szsb_avg = rowMeans(select(.,
SZSB_1,
SZSB_2,
SZSB_3,
SZSB_4,
SZSB_5R_Recoded,
SZSB_6R_Recoded,
SZSB_7R_Recoded,
SZSB_8R_Recoded
), na.rm = TRUE)
)df_numeric <- df_numeric %>%
mutate(
nfs_avg = rowMeans(select(.,
need.for.status_1,
need.for.status_2R_Recoded,
need.for.status_3,
need.for.status_4,
need.for.status_5,
need.for.status_6,
need.for.status_7R_Recoded,
need.for.status_8
), na.rm = TRUE)
)df_numeric <- df_numeric %>%
mutate(
sdo_avg = rowMeans(select(.,
sdo_1,
sdo_2,
sdo_3R_Recoded,
sdo_4R_Recoded,
sdo_5,
sdo_6,
sdo_7R_Recoded,
sdo_8R_Recoded
), na.rm = TRUE)
)df_numeric <- df_numeric %>%
mutate(
dominance_avg = rowMeans(select(.,
dom_1,
dom_2,
dom_3,
dom_4,
dom_5R_Recoded,
dom_6,
dom_7R_Recoded,
dom_8
), na.rm = TRUE)
)df_numeric <- df_numeric %>%
mutate(
prestige_avg = rowMeans(select(.,
prest_1,
prest_2R_Recoded,
prest_3,
prest_4R_Recoded,
prest_5,
prest_6,
prest_7,
prest_8,
prest_9R_Recoded
), na.rm = TRUE)
)Quick alpha check
items <- df_numeric %>%
select(dist_1R_Recoded,
dist_2R_Recoded,
dist_5R_Recoded,
dist_14,
dist_15,
dist_16,
attr_3,
attr_4,
attr_5,
attr_6,
attr_8,
attr_10) %>%
na.omit()
psych::alpha(items) # 0.86##
## Reliability analysis
## Call: psych::alpha(x = items)
##
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd median_r
## 0.86 0.87 0.92 0.36 6.6 0.02 5.4 0.86 0.33
##
## 95% confidence boundaries
## lower alpha upper
## Feldt 0.82 0.86 0.9
## Duhachek 0.82 0.86 0.9
##
## Reliability if an item is dropped:
## raw_alpha std.alpha G6(smc) average_r S/N alpha se var.r med.r
## dist_1R_Recoded 0.84 0.86 0.90 0.35 5.9 0.023 0.027 0.34
## dist_2R_Recoded 0.85 0.86 0.91 0.36 6.2 0.022 0.026 0.35
## dist_5R_Recoded 0.84 0.86 0.90 0.35 6.0 0.023 0.027 0.33
## dist_14 0.85 0.86 0.91 0.35 6.0 0.022 0.034 0.33
## dist_15 0.86 0.87 0.91 0.37 6.5 0.021 0.030 0.34
## dist_16 0.85 0.85 0.90 0.35 5.9 0.022 0.034 0.32
## attr_3 0.85 0.85 0.90 0.35 5.8 0.022 0.030 0.32
## attr_4 0.85 0.86 0.91 0.35 6.0 0.021 0.030 0.33
## attr_5 0.85 0.86 0.91 0.36 6.1 0.021 0.031 0.34
## attr_6 0.86 0.87 0.91 0.38 6.8 0.019 0.027 0.35
## attr_8 0.84 0.85 0.90 0.34 5.7 0.022 0.031 0.32
## attr_10 0.85 0.86 0.91 0.36 6.1 0.021 0.035 0.34
##
## Item statistics
## n raw.r std.r r.cor r.drop mean sd
## dist_1R_Recoded 100 0.76 0.68 0.68 0.67 4.3 1.87
## dist_2R_Recoded 100 0.70 0.61 0.60 0.59 4.3 1.82
## dist_5R_Recoded 100 0.75 0.67 0.66 0.66 4.3 1.87
## dist_14 100 0.63 0.65 0.61 0.55 5.9 1.16
## dist_15 100 0.57 0.54 0.50 0.46 5.3 1.51
## dist_16 100 0.68 0.69 0.67 0.60 5.3 1.37
## attr_3 100 0.65 0.70 0.68 0.58 6.0 1.01
## attr_4 100 0.61 0.67 0.64 0.53 5.9 1.14
## attr_5 100 0.58 0.64 0.61 0.51 6.0 1.06
## attr_6 100 0.37 0.45 0.39 0.28 6.0 1.11
## attr_8 100 0.71 0.75 0.74 0.65 6.0 1.13
## attr_10 100 0.57 0.62 0.57 0.50 5.9 0.97
##
## Non missing response frequency for each item
## 1 2 3 4 5 6 7 miss
## dist_1R_Recoded 0.09 0.11 0.18 0.13 0.12 0.27 0.10 0
## dist_2R_Recoded 0.05 0.18 0.15 0.11 0.16 0.25 0.10 0
## dist_5R_Recoded 0.07 0.17 0.14 0.11 0.17 0.23 0.11 0
## dist_14 0.00 0.03 0.02 0.06 0.12 0.45 0.32 0
## dist_15 0.02 0.03 0.09 0.13 0.17 0.32 0.24 0
## dist_16 0.01 0.04 0.05 0.14 0.23 0.34 0.19 0
## attr_3 0.01 0.00 0.02 0.03 0.14 0.47 0.33 0
## attr_4 0.01 0.02 0.01 0.04 0.16 0.44 0.32 0
## attr_5 0.01 0.01 0.02 0.01 0.18 0.47 0.30 0
## attr_6 0.01 0.01 0.02 0.03 0.15 0.43 0.35 0
## attr_8 0.01 0.00 0.05 0.02 0.10 0.44 0.38 0
## attr_10 0.00 0.00 0.03 0.04 0.20 0.43 0.30 0Status Affordance Analysis
Remove people that did not nominate at least three coworkers
df_manager <- data %>%
select(ResponseId, managerTenure:industry, selected1:selected3) %>%
filter(
!is.na(selected1) & !(tolower(selected1) %in% c("n/a", "na")),
!is.na(selected2) & !(tolower(selected2) %in% c("n/a", "na")),
!is.na(selected3) & !(tolower(selected3) %in% c("n/a", "na"))
)
df_full <- df_manager %>%
left_join(df_numeric, by = "ResponseId")Create averages
df_full <- df_full %>%
mutate(
selected1_status_avg = rowMeans(select(.,
affordance1_1,
affordance1_2,
affordance1_3),
na.rm = TRUE)
)
df_full <- df_full %>%
mutate(
selected2_status_avg = rowMeans(select(.,
affordance2_1,
affordance2_2,
affordance2_3),
na.rm = TRUE)
)
df_full <- df_full %>%
mutate(
selected3_status_avg = rowMeans(select(.,
affordance3_1,
affordance3_2,
affordance3_3),
na.rm = TRUE)
)df_long <- df_full %>%
select(ResponseId, status_expansion_belief, selected1, selected2, selected3,
selected1_status_avg, selected2_status_avg, selected3_status_avg) %>%
pivot_longer(
cols = c(selected1_status_avg, selected2_status_avg, selected3_status_avg),
names_to = "slot",
values_to = "affordance_score"
) %>%
# extract which slot (1/2/3) we’re on
mutate(slot_num = str_extract(slot, "\\d")) %>%
# map the slot back to the corresponding direct report ID
mutate(report_id = case_when(
slot_num == "1" ~ as.character(selected1),
slot_num == "2" ~ as.character(selected2),
slot_num == "3" ~ as.character(selected3)
)) %>%
# final analysis columns
select(ResponseId, report_id, affordance_score, status_expansion_belief)Simple MLM
library(lme4)## Loading required package: Matrix##
## Attaching package: 'Matrix'## The following objects are masked from 'package:tidyr':
##
## expand, pack, unpacklibrary(lmerTest)##
## Attaching package: 'lmerTest'## The following object is masked from 'package:lme4':
##
## lmer## The following object is masked from 'package:stats':
##
## step# Grand-mean center predictor for interpretability
df_long <- df_long %>%
mutate(status_expansion_c = scale(status_expansion_belief, center = TRUE, scale = FALSE)[,1])
# Model: does status expansion predict affordance?
m1 <- lmer(affordance_score ~ status_expansion_c + (1 | ResponseId), data = df_long, REML = TRUE)
summary(m1)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: affordance_score ~ status_expansion_c + (1 | ResponseId)
## Data: df_long
##
## REML criterion at convergence: 866.1
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.5788 -0.3948 0.1637 0.4284 2.6739
##
## Random effects:
## Groups Name Variance Std.Dev.
## ResponseId (Intercept) 0.4540 0.6738
## Residual 0.9208 0.9596
## Number of obs: 282, groups: ResponseId, 94
##
## Fixed effects:
## Estimate Std. Error df t value Pr(>|t|)
## (Intercept) 5.61939 0.08997 92.00000 62.457 < 2e-16 ***
## status_expansion_c 0.55869 0.10202 92.00000 5.477 3.74e-07 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr)
## stts_xpnsn_ 0.000For each 1-unit increase in status expansion beliefs, managers are afford about 0.56 points more status to their direct reports.The effect is statistically significant (t = 5.477, p < .001).
With controls
df_long_controls <- df_full %>%
select(ResponseId, status_expansion_belief, selected1, selected2, selected3,
selected1_status_avg, selected2_status_avg, selected3_status_avg, szsb_avg, nfs_avg, sdo_avg, dominance_avg, prestige_avg) %>%
pivot_longer(
cols = c(selected1_status_avg, selected2_status_avg, selected3_status_avg),
names_to = "slot",
values_to = "affordance_score"
) %>%
# extract which slot (1/2/3) we’re on
mutate(slot_num = str_extract(slot, "\\d")) %>%
# map the slot back to the corresponding direct report ID
mutate(report_id = case_when(
slot_num == "1" ~ as.character(selected1),
slot_num == "2" ~ as.character(selected2),
slot_num == "3" ~ as.character(selected3)
)) %>%
# final analysis columns
select(ResponseId, report_id, affordance_score, status_expansion_belief, szsb_avg, nfs_avg, sdo_avg, dominance_avg, prestige_avg)# Grand-mean center predictor for interpretability
df_long_controls <- df_long_controls %>%
mutate(status_expansion_c = scale(status_expansion_belief, center = TRUE, scale = FALSE)[,1])m2 <- lmer(affordance_score ~ status_expansion_c + szsb_avg + nfs_avg + sdo_avg + dominance_avg + prestige_avg + (1 | ResponseId), data = df_long_controls, REML = TRUE)
summary(m2)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: affordance_score ~ status_expansion_c + szsb_avg + nfs_avg +
## sdo_avg + dominance_avg + prestige_avg + (1 | ResponseId)
## Data: df_long_controls
##
## REML criterion at convergence: 874.7
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.6013 -0.3649 0.1332 0.4680 2.6514
##
## Random effects:
## Groups Name Variance Std.Dev.
## ResponseId (Intercept) 0.4535 0.6734
## Residual 0.9208 0.9596
## Number of obs: 282, groups: ResponseId, 94
##
## Fixed effects:
## Estimate Std. Error df t value Pr(>|t|)
## (Intercept) 5.777297 0.618125 86.999975 9.346 8.77e-15 ***
## status_expansion_c 0.486808 0.129522 86.999976 3.758 0.000309 ***
## szsb_avg -0.005860 0.129060 86.999976 -0.045 0.963889
## nfs_avg -0.003457 0.137037 86.999977 -0.025 0.979930
## sdo_avg -0.151539 0.070168 86.999976 -2.160 0.033549 *
## dominance_avg 0.068205 0.109803 86.999976 0.621 0.536119
## prestige_avg 0.010844 0.161819 86.999977 0.067 0.946726
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) stts__ szsb_v nfs_vg sdo_vg dmnnc_
## stts_xpnsn_ -0.241
## szsb_avg -0.603 0.302
## nfs_avg -0.067 -0.097 0.066
## sdo_avg -0.270 0.330 0.183 0.189
## dominanc_vg 0.170 0.217 -0.429 -0.320 -0.267
## prestige_vg -0.420 -0.055 0.060 -0.749 -0.158 -0.028The core finding (status expansion beliefs → more status affordance) is robust: the effect remains significant and meaningful even after adjusting for related constructs (SZSB, NFS, SDO, dominance, prestige). SDO emerges as an additional significant predictor, but in the opposite direction. Other status-related constructs don’t explain unique variance in affordance once expansion beliefs are in the model.
Do high SEB people rate everyone high?
library(lmtest)## Loading required package: zoo##
## Attaching package: 'zoo'## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numericlibrary(sandwich)
# Within-rater dispersion (SD across the 3 rated targets)
rater_dispersion <- df_full %>%
transmute(
ResponseId,
SEB = status_expansion_belief,
mean_aff = rowMeans(cbind(selected1_status_avg, selected2_status_avg, selected3_status_avg), na.rm = TRUE),
sd_aff = apply(cbind(selected1_status_avg, selected2_status_avg, selected3_status_avg), 1, sd, na.rm = TRUE),
iqr_aff = apply(cbind(selected1_status_avg, selected2_status_avg, selected3_status_avg), 1, IQR, na.rm = TRUE)
)
# Does SEB predict the mean AND/OR the spread across targets?
m_mean <- lm(mean_aff ~ scale(SEB, center=TRUE, scale=FALSE), data = rater_dispersion)
m_sd <- lm(sd_aff ~ scale(SEB, center=TRUE, scale=FALSE), data = rater_dispersion)
m_iqr <- lm(iqr_aff ~ scale(SEB, center=TRUE, scale=FALSE), data = rater_dispersion)
coeftest(m_mean, vcov = vcovHC(m_mean, type = "HC3"))##
## t test of coefficients:
##
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 5.619385 0.091393 61.4860 < 2.2e-16
## scale(SEB, center = TRUE, scale = FALSE) 0.558691 0.125705 4.4445 2.455e-05
##
## (Intercept) ***
## scale(SEB, center = TRUE, scale = FALSE) ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1coeftest(m_sd, vcov = vcovHC(m_sd, type = "HC3"))##
## t test of coefficients:
##
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.677477 0.064412 10.518 < 2.2e-16
## scale(SEB, center = TRUE, scale = FALSE) -0.338802 0.077832 -4.353 3.477e-05
##
## (Intercept) ***
## scale(SEB, center = TRUE, scale = FALSE) ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1coeftest(m_iqr, vcov = vcovHC(m_iqr, type = "HC3"))##
## t test of coefficients:
##
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.638298 0.062040 10.2884 < 2.2e-16
## scale(SEB, center = TRUE, scale = FALSE) -0.318930 0.074979 -4.2536 5.05e-05
##
## (Intercept) ***
## scale(SEB, center = TRUE, scale = FALSE) ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Looks like yeah. Here SEB predicts both the mean and the spread. High SEB –> higher mean, and SEB –> lower st dev. and lower IQR. We did not observe these results for spread in our pilot of 50 managers.
What about across items
# Long per-item data: 3 targets × 3 items = 9 rows per rater
df_items <- df_full %>%
select(ResponseId, status_expansion_belief,
affordance1_1:affordance1_3,
affordance2_1:affordance2_3,
affordance3_1:affordance3_3) %>%
pivot_longer(cols = starts_with("affordance"),
names_to = "which",
values_to = "score") %>%
mutate(
target = str_extract(which, "(?<=affordance)\\d+(?=_)"),
item = str_extract(which, "(?<=_)\\d+"),
SEB_c = scale(status_expansion_belief, center=TRUE, scale=FALSE)[,1]
)
# Does SEB predict each item? (random intercept for rater)
m_item <- lmer(score ~ SEB_c + item + (1|ResponseId), data = df_items, REML = TRUE)
summary(m_item)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: score ~ SEB_c + item + (1 | ResponseId)
## Data: df_items
##
## REML criterion at convergence: 2582.3
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.7713 -0.3897 0.1492 0.4743 4.0455
##
## Random effects:
## Groups Name Variance Std.Dev.
## ResponseId (Intercept) 0.6509 0.8068
## Residual 0.9899 0.9949
## Number of obs: 846, groups: ResponseId, 94
##
## Fixed effects:
## Estimate Std. Error df t value Pr(>|t|)
## (Intercept) 5.92199 0.10215 151.32910 57.972 < 2e-16 ***
## SEB_c 0.55869 0.10202 92.00000 5.477 3.74e-07 ***
## item2 -0.49291 0.08379 750.00000 -5.883 6.08e-09 ***
## item3 -0.41489 0.08379 750.00000 -4.952 9.09e-07 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) SEB_c item2
## SEB_c 0.000
## item2 -0.410 0.000
## item3 -0.410 0.000 0.500# Do items differ in slope? (test interaction)
m_item_int <- lmer(score ~ SEB_c*item + (1|ResponseId), data = df_items, REML = TRUE)
anova(m_item, m_item_int) # if non-sig, slopes are similar across items## refitting model(s) with ML (instead of REML)## Data: df_items
## Models:
## m_item: score ~ SEB_c + item + (1 | ResponseId)
## m_item_int: score ~ SEB_c * item + (1 | ResponseId)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## m_item 6 2582.0 2610.5 -1285.0 2570.0
## m_item_int 8 2585.7 2623.7 -1284.9 2569.7 0.3042 2 0.8589No, items don’t statistically differ in slope.
How many nominations on average
report_cols <- paste0("report", 1:10)
df_reports <- data %>%
# include the report columns so we can clean them
select(ResponseId, all_of(report_cols)) %>%
# turn "", "na", "n/a" (with any whitespace) into NA
mutate(across(all_of(report_cols),
~ na_if(str_squish(as.character(.)), ""))) %>%
mutate(across(all_of(report_cols),
~ ifelse(tolower(.) %in% c("na","n/a"), NA, .))) %>%
# count non-missing reports per manager
mutate(n_nominations = rowSums(across(all_of(report_cols), ~ !is.na(.))))
mean(df_reports$n_nominations)## [1] 6.35Is the distribution of SEBs skewed or normal?
# Histogram with density curve
ggplot(df_full, aes(x = status_expansion_belief)) +
geom_histogram(aes(y = ..density..), bins = 20, fill = "grey70", color = "black") +
geom_density(color = "blue", size = 1) +
labs(x = "Status Expansion Belief (SEB)", y = "Density",
title = "Distribution of SEB")## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.## Warning: The dot-dot notation (`..density..`) was deprecated in ggplot2 3.4.0.
## ℹ Please use `after_stat(density)` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
Now let’s look at the free response data
Create a text df
text_long <- data %>%
select(ResponseId,
affordance1_explain, affordance2_explain, affordance3_explain) %>%
pivot_longer(
cols = starts_with("affordance"),
names_to = "slot",
values_to = "response_text"
) %>%
mutate(
slot_num = str_extract(slot, "\\d"),
response_text = coalesce(trimws(response_text), "")
)Manually create categories
dict <- tribble(
~category, ~pattern,
"work_ethic", "(?i)\\b(hard\\s*work(?:ing)?|diligent|dedicat(?:ed|ion)|dependable|reliable|consistent|punctual|loyal|professional|work\\s*ethic|above\\s+and\\s+beyond|always\\s+available)\\b",
"technical", "(?i)\\b(knowledgeable|skill(?:ed)?|expert|technical|competent|smart|intelligen\\w+|brilliant|educated|talent\\w+|subject[-\\s]?matter|analyst|sql|excel|python|data|model(?:ling|ing)?)\\b",
"interpersonal", "(?i)\\b(empath(?:y|etic)|emotional\\s+intelligence|kind(?:ness)?|caring|supportive|friendly|approachable|easy\\s+to\\s+work\\s+with|people\\s+skills|humou?r|team\\s*player|collaborative|good\\s+listener)\\b",
"leadership", "(?i)\\b(lead(?:er|ership)?|initiative|motivates?|influence|ownership|vision|guidance|train(?:s|ing)?|mentor(?:s|ing)?|coach(?:es|ing)?|develops?\\s+others|delegat(?:es|ion))\\b",
"efficiency", "(?i)\\b(fast|efficient|productiv\\w+|organized|multi-?task\\w*|gets\\s+things\\s+done|deliver(?:s|y|ed)?|quick(?:ly)?)\\b",
"creativity", "(?i)\\b(creative|innovation|innovative|problem\\s*-?solv\\w+|resourceful|idea\\w+|ingenuity)\\b",
"communication", "(?i)\\b(communicat(?:e|es|ion|or)|explain(?:s|ed|ing)?|clear(?:ly)?|persuasive|feedback|writes?|presentation|articulate)\\b"
)
code_with_dictionary <- function(text_vec, dict_tbl) {
txt <- dplyr::coalesce(as.character(text_vec), "")
purrr::map_dfc(seq_len(nrow(dict_tbl)), function(i) {
cat <- dict_tbl$category[i]
patt <- dict_tbl$pattern[i]
tibble(!!cat := stringr::str_detect(txt, regex(patt)))
})
}
coded_text <- text_long %>%
bind_cols(code_with_dictionary(.$response_text, dict)) %>%
mutate(
domain_diversity = rowSums(across(all_of(dict$category)))
) %>%
select(ResponseId, slot_num, response_text, domain_diversity, all_of(dict$category)) %>%
mutate(slot_num = as.character(slot_num))Create the combined df
df_long_text_controls_slot <- df_full %>%
select(ResponseId, status_expansion_belief, selected1, selected2, selected3,
selected1_status_avg, selected2_status_avg, selected3_status_avg, szsb_avg, nfs_avg, sdo_avg, dominance_avg, prestige_avg) %>%
pivot_longer(
cols = c(selected1_status_avg, selected2_status_avg, selected3_status_avg),
names_to = "slot",
values_to = "affordance_score"
) %>%
# extract which slot (1/2/3) we’re on
mutate(slot_num = str_extract(slot, "\\d")) %>%
# map the slot back to the corresponding direct report ID
mutate(report_id = case_when(
slot_num == "1" ~ as.character(selected1),
slot_num == "2" ~ as.character(selected2),
slot_num == "3" ~ as.character(selected3)
)) %>%
# final analysis columns
select(ResponseId, report_id, slot_num, affordance_score, status_expansion_belief, szsb_avg, nfs_avg, sdo_avg, dominance_avg, prestige_avg)df_long_text_dictionary <- df_long_text_controls_slot %>%
left_join(coded_text, by = c("ResponseId","slot_num"))Look at category breakdown
# category totals
colSums(select(df_long_text_dictionary, all_of(dict$category)))## work_ethic technical interpersonal leadership efficiency
## 77 57 56 20 18
## creativity communication
## 20 17MLM w/ domain diversity
# Grand-mean center predictor for interpretability
df_long_text_dictionary <- df_long_text_dictionary %>%
mutate(status_expansion_c = scale(status_expansion_belief, center = TRUE, scale = FALSE)[,1])
m3 <- lmer(affordance_score ~ status_expansion_c + domain_diversity + (1 | ResponseId),
data = df_long_text_dictionary)
summary(m3)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: affordance_score ~ status_expansion_c + domain_diversity + (1 |
## ResponseId)
## Data: df_long_text_dictionary
##
## REML criterion at convergence: 862.4
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.6613 -0.3718 0.1463 0.4836 2.6007
##
## Random effects:
## Groups Name Variance Std.Dev.
## ResponseId (Intercept) 0.4123 0.6421
## Residual 0.9181 0.9581
## Number of obs: 282, groups: ResponseId, 94
##
## Fixed effects:
## Estimate Std. Error df t value Pr(>|t|)
## (Intercept) 5.42058 0.11521 183.83300 47.050 < 2e-16 ***
## status_expansion_c 0.54043 0.09936 91.39141 5.439 4.44e-07 ***
## domain_diversity 0.21156 0.07986 261.39202 2.649 0.00856 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) stts__
## stts_xpnsn_ 0.045
## domn_dvrsty -0.651 -0.069Managers higher in SEB tend to give higher affordance scores to all of their subordinates. This is the across-the-board effect: SEB is manager-level so it shifts all three ratings up.
Within managers, subordinates described with more distinct categories get higher affordance. This is a within-manager effect: if a manager mentions 2 categories for one report and 1 for another, the first gets higher affordance.
Now, I want to know what happens if we look at domains as a manager-level variable.
Add a unique domain count at the manager level
domains <- c("work_ethic","technical","interpersonal",
"leadership","efficiency","creativity","communication")
# Compute manager-level unique domain count
df_mgr_unique <- df_long_text_dictionary %>%
group_by(ResponseId) %>%
summarise(
unique_domain_count = rowSums(across(all_of(domains), ~ any(.))),
.groups = "drop"
)
df_long_text_dictionary <- df_long_text_dictionary %>%
left_join(df_mgr_unique, by = "ResponseId")MLM w/ unique domain breadth
m5 <- lmer(affordance_score ~ status_expansion_c + unique_domain_count +
(1 | ResponseId),
data = df_long_text_dictionary)
summary(m5)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: affordance_score ~ status_expansion_c + unique_domain_count +
## (1 | ResponseId)
## Data: df_long_text_dictionary
##
## REML criterion at convergence: 857.9
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.5151 -0.3138 0.1300 0.4310 2.7376
##
## Random effects:
## Groups Name Variance Std.Dev.
## ResponseId (Intercept) 0.3731 0.6108
## Residual 0.9208 0.9596
## Number of obs: 282, groups: ResponseId, 94
##
## Fixed effects:
## Estimate Std. Error df t value Pr(>|t|)
## (Intercept) 5.02352 0.19223 91.00000 26.132 < 2e-16 ***
## status_expansion_c 0.48035 0.09907 91.00000 4.849 5.1e-06 ***
## unique_domain_count 0.27592 0.07983 91.00000 3.456 0.000834 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) stts__
## stts_xpnsn_ 0.205
## unq_dmn_cnt -0.897 -0.229A mixed model predicting affordance scores revealed significant effects of both status expansion beliefs (b = 0.48, SE = 0.10, p < .001) and managers’ unique-domain breadth across their team (b = 0.28, SE = 0.08, p < .001). This indicates that managers with higher expansion beliefs confer more status overall, and independently, managers who recognize a broader set of distinct domains across their team also afford more status.
Mediation at the aggregate level (not MLM)
mgr_level <- df_long_text_dictionary %>%
group_by(ResponseId) %>%
summarise(
SEB = mean(status_expansion_belief, na.rm = TRUE),
mean_affordance = mean(affordance_score, na.rm = TRUE),
unique_domain_count = mean(unique_domain_count, na.rm = TRUE), # same for all rows
.groups = "drop"
)library(lavaan)
model_med <- '
# path a
unique_domain_count ~ a*SEB
# path b and c’
mean_affordance ~ cprime*SEB + b*unique_domain_count
# indirect and total
indirect := a*b
total := cprime + (a*b)
'
fit_med <- sem(model_med, data = mgr_level,
se = "bootstrap", bootstrap = 5000) # bootstrap CI recommended
summary(fit_med, standardized = TRUE, fit.measures = TRUE, rsquare = TRUE)## lavaan 0.6-18 ended normally after 1 iteration
##
## Estimator ML
## Optimization method NLMINB
## Number of model parameters 5
##
## Number of observations 94
##
## Model Test User Model:
##
## Test statistic 0.000
## Degrees of freedom 0
##
## Model Test Baseline Model:
##
## Test statistic 43.174
## Degrees of freedom 3
## P-value 0.000
##
## User Model versus Baseline Model:
##
## Comparative Fit Index (CFI) 1.000
## Tucker-Lewis Index (TLI) 1.000
##
## Loglikelihood and Information Criteria:
##
## Loglikelihood user model (H0) -253.072
## Loglikelihood unrestricted model (H1) -253.072
##
## Akaike (AIC) 516.144
## Bayesian (BIC) 528.860
## Sample-size adjusted Bayesian (SABIC) 513.075
##
## Root Mean Square Error of Approximation:
##
## RMSEA 0.000
## 90 Percent confidence interval - lower 0.000
## 90 Percent confidence interval - upper 0.000
## P-value H_0: RMSEA <= 0.050 NA
## P-value H_0: RMSEA >= 0.080 NA
##
## Standardized Root Mean Square Residual:
##
## SRMR 0.000
##
## Parameter Estimates:
##
## Standard errors Bootstrap
## Number of requested bootstrap draws 5000
## Number of successful bootstrap draws 5000
##
## Regressions:
## Estimate Std.Err z-value P(>|z|) Std.lv Std.all
## unique_domain_count ~
## SEB (a) 0.284 0.145 1.954 0.051 0.284 0.229
## mean_affordance ~
## SEB (cprm) 0.480 0.104 4.641 0.000 0.480 0.426
## unq_dm_ (b) 0.276 0.078 3.549 0.000 0.276 0.304
##
## Variances:
## Estimate Std.Err z-value P(>|z|) Std.lv Std.all
## .unique_dmn_cnt 1.135 0.148 7.679 0.000 1.135 0.948
## .mean_affordanc 0.658 0.167 3.933 0.000 0.658 0.667
##
## R-Square:
## Estimate
## unique_dmn_cnt 0.052
## mean_affordanc 0.333
##
## Defined Parameters:
## Estimate Std.Err z-value P(>|z|) Std.lv Std.all
## indirect 0.078 0.048 1.645 0.100 0.078 0.070
## total 0.559 0.121 4.616 0.000 0.559 0.496parameterEstimates(fit_med, standardized = TRUE,
boot.ci.type = "perc") %>%
subset(op %in% c("~", ":="))## lhs op rhs label est se z pvalue
## 1 unique_domain_count ~ SEB a 0.284 0.145 1.954 0.051
## 2 mean_affordance ~ SEB cprime 0.480 0.104 4.641 0.000
## 3 mean_affordance ~ unique_domain_count b 0.276 0.078 3.549 0.000
## 7 indirect := a*b indirect 0.078 0.048 1.645 0.100
## 8 total := cprime+(a*b) total 0.559 0.121 4.616 0.000
## ci.lower ci.upper std.lv std.all std.nox
## 1 0.009 0.579 0.284 0.229 0.259
## 2 0.276 0.682 0.480 0.426 0.483
## 3 0.119 0.428 0.276 0.304 0.304
## 7 0.002 0.189 0.078 0.070 0.079
## 8 0.328 0.788 0.559 0.496 0.562We tested whether managers’ breadth of unique domains recognized across their team mediated the relationship between status expansion beliefs (SEB) and status affordance. SEB strongly predicted affordance directly (b = .48, p < .001). Unique-domain breadth also predicted affordance (b = .28, p = .001). However, the path from SEB to unique-domain breadth was only marginal (b = .28, p = .057), and the indirect effect was small and non-significant (indirect = .08, p = .11). So, it appears that SEB and breadth of domains independently predict affordance, but domain breadth does not mediate the effect of SEB.