Chapter 3 Method 1: Pooled One Stage Models without Study-Specific Effects
Method 1 is a fully pooled procedure in which a single estimate of a prospective Big Five personality characteristic-crystallized ability association is estimated across samples. In other words, there are no sample-specific estimates of the associations.
3.1 Step 1: Combine Data
loadRData <- function(fileName, type){
#loads an RData file, and returns it
path <- sprintf("%s/data/clean/%s_cleaned.RData", local_path, fileName)
load(path)
get(ls()[grepl(type, ls())])
}
ipd_reg_data <- tibble(
study = studies[!studies %in% c("CNLSY", "SLS")]
, data = map(str_to_lower(study), ~loadRData(., "combined"))
) %>% mutate(
data = map(data, ~(.) %>%
ungroup() %>%
mutate(SID = as.character(SID)))
, study = mapvalues(study, studies, studies_long)
) %>%
unnest(data) %>%
mutate(age = ifelse(is.na(age), p_year - yearBrth, age))
ipd_reg_data## # A tibble: 119,597 × 13
## study Trait p_value p_year SID Outcome o_value o_year education gender SRhealth yearBrth age
## <chr> <chr> <dbl> <dbl> <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 BASE E 3.83 1990 10004 crystallized 2.17 2000 17 0 4 1918 72
## 2 BASE E 3.83 1990 10010 crystallized 3.08 1995 11 0 2 1911 79
## 3 BASE E 2.5 1990 10033 crystallized 0.909 1997 8 1 5 1910 80
## 4 BASE E 3 1990 10034 crystallized 6.54 1995 10 0 5 1914 76
## 5 BASE E 2.5 1990 10111 crystallized 6.54 1995 13 1 4 1901 89
## 6 BASE E 3.17 1990 10115 crystallized 10 1995 11 0 2 1918 72
## 7 BASE E 3 1990 10116 crystallized 3.85 1995 10 0 4 1917 73
## 8 BASE E 3 1990 10145 crystallized 6.36 1997 10 1 5 1897 93
## 9 BASE E 3.33 1990 10175 crystallized 2.31 1995 8 1 3 1911 79
## 10 BASE E 3.33 1990 10188 crystallized 5.77 2004 10 1 2 1903 87
## # ℹ 119,587 more rows3.1.1 Study-Level Moderators
First, we need to bring in a few study-level moderators from Table 4, which includes information about the continent and country of origin, and the type of personality scale. Then we’ll join those data with cleaned data from each study in order to calculate the average age at baseline, the average baseline year, and the average interval between personality and cogntiive measurements. Because these vary within studies across personality traits and outcomes, we calculate baseline age, year, and prediction interval for all combinations of these separately.
ipd_reg_data <- sprintf("%s/codebooks/crystallized_tables.xlsx", local_path) %>%
read_xlsx(., sheet = "Table 4") %>%
select(-Category, -Construct, -category) %>%
pivot_longer(cols = c("BASE-I":"SATSA")
, names_to = "study"
, values_to = "value") %>%
pivot_wider(names_from = "name"
, values_from = "value") %>%
mutate(continent = relevel(factor(continent), ref = "North America")
, country = relevel(factor(country), ref = "United States")
, scale = relevel(factor(scale), ref = "NEO-FFI")) %>%
# mutate(p_year = as.numeric(p_year)) %>%
right_join(ipd_reg_data) %>%
group_by(study, Trait, Outcome) %>%
mutate(baseAge = mean(age, na.rm = T) - 60, # center at age 60
predInt = mean(o_year - p_year) - 5, # center at 5 years
baseYear = ifelse(study %in% c("MARS", "MAP", "ROS"), mean(p_year), mean(p_year) - 2000)) %>% # center at 2000
ungroup()
ipd_reg_data## # A tibble: 119,597 × 19
## study continent country scale baseAge baseYear predInt Trait p_value p_year SID Outcome o_value o_year education gender
## <chr> <fct> <fct> <fct> <dbl> <dbl> <dbl> <chr> <dbl> <dbl> <chr> <chr> <dbl> <dbl> <dbl> <dbl>
## 1 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 3.7 2006 8024 crysta… 6.68 2006 10 0
## 2 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 3.6 2006 8265 crysta… 6.36 2011 12 0
## 3 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 5 2006 8296 crysta… 5.23 2006 14 0
## 4 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 4.4 2006 8375 crysta… 4.77 2010 12 1
## 5 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 3.2 2006 8597 crysta… 7.73 2009 14 0
## 6 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 4 2006 8622 crysta… 9.5 2011 19 1
## 7 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 4.2 2006 8634 crysta… 4.09 2007 12 0
## 8 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 4.2 2006 8637 crysta… 1.41 2006 8 1
## 9 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 4.5 2006 8674 crysta… 2.32 2006 14 1
## 10 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 4.1 2006 8675 crysta… 6.09 2006 15 0
## # ℹ 119,587 more rows
## # ℹ 3 more variables: SRhealth <dbl>, yearBrth <dbl>, age <dbl>3.1.2 Harmonize Data
Next, we need to harmonize the data across studies. As we preregistered, continuous variables (personality, cognition, and self-rated health) will be calclulated as percentages of maximum possible separately for each study, Trait and outcome. Unlike standardization procedures, that have a mean of zero and unit variance and can be misleading when data are skewed, POMP does not rescale sample variance based on the observed data, which overly relies on deviations from the mean. Instead, POMP relies on the ratio between the difference between a score and the minimum and the maximum and minimum, or
POMP = \(\frac{observed-minimum}{maximum-minimum}\)*10.
In addition, gender will be dummy coded with male as the reference group, education will be centered at 12 years of education, and age will be grand mean-centered in each study (also for each trait and outcome combination).
ipd_reg_data <- ipd_reg_data %>%
group_by(study, Trait, Outcome) %>%
mutate_at(vars(p_value, o_value),
~((. - min(., na.rm = T))/(max(., na.rm = T) - min(., na.rm = T))*10)) %>%
mutate(gender = factor(gender, levels = c(0,1), labels = c("Male", "Female")),
education = education - 12, # center at 12 years of education
age = age - mean(age, na.rm = T)) %>% # center
ungroup() %>%
select(-yearBrth)
ipd_reg_data## # A tibble: 119,597 × 18
## study continent country scale baseAge baseYear predInt Trait p_value p_year SID Outcome o_value o_year education gender
## <chr> <fct> <fct> <fct> <dbl> <dbl> <dbl> <chr> <dbl> <dbl> <chr> <chr> <dbl> <dbl> <dbl> <fct>
## 1 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 5.81 2006 8024 crysta… 6.68 2006 -2 Male
## 2 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 5.48 2006 8265 crysta… 6.36 2011 0 Male
## 3 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 10 2006 8296 crysta… 5.23 2006 2 Male
## 4 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 8.06 2006 8375 crysta… 4.77 2010 0 Female
## 5 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 4.19 2006 8597 crysta… 7.73 2009 2 Male
## 6 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 6.77 2006 8622 crysta… 9.5 2011 7 Female
## 7 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 7.42 2006 8634 crysta… 4.09 2007 0 Male
## 8 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 7.42 2006 8637 crysta… 1.41 2006 -4 Female
## 9 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 8.39 2006 8674 crysta… 2.32 2006 2 Female
## 10 EAS North Ame… United… IPIP… 19.5 11.0 -2.85 A 7.10 2006 8675 crysta… 6.09 2006 3 Male
## # ℹ 119,587 more rows
## # ℹ 2 more variables: SRhealth <dbl>, age <dbl>3.1.3 Save Data Files
Now, we’ll save these data files into separate data files for each trait, outcome combination. This makes it easier to track each data set that will be used in subsequent analyses.
save_fun <- function(d, trait, outcome){
save(d, file = sprintf("%s/data/one_stage/%s_%s.RData", local_path, trait, outcome))
}
ipd_reg_data %>%
group_by(Trait, Outcome) %>%
nest() %>%
ungroup() %>%
mutate(data = pmap(list(data, Trait, Outcome), save_fun))## # A tibble: 5 × 3
## Trait Outcome data
## <chr> <chr> <list>
## 1 A crystallized <NULL>
## 2 C crystallized <NULL>
## 3 E crystallized <NULL>
## 4 N crystallized <NULL>
## 5 O crystallized <NULL>3.2 Step 2: Run Models and Extract Results
Once the data are prepped, we are ready to begin running models! For Method 1: Pooled One Stage Models without Study-Specific Effects, we will run two variants. The first is a simple linear regression that does not account for nesting / clustering in the data (specifically individuals within studies). The second is a simple linear regression with cluster-robust standard errors. The latter is of particular interest and benefit when study-specific effects are not of interest and one wants the best estimate of an aggregate, fixed effect.
3.2.1 Method 1A: Linear Regression
3.2.1.1 Analytic Plan
In the present study, we aimed to examine associations between personality traits and crystallized cognitive abilities using fully pooled, single-stage regression models with individual participant data. Below, we detail each stage of the analysis.
3.2.1.1.1 Statistical Modeling
A single regression model tests the relationship between personality and crystallized cognitive ability across all samples. Using the R programming language, we created a series of functions to (1) set up and run the model and extract model coefficients and (2) extract simple-effects predictions for moderator models (i.e. predicted values across levels of the moderator values). The basic, unadjusted form of the model is as follows:
\(Y_{ij} = b_0 + b_1 \ast predictor_{ij} + \epsilon_{ij}\) \(\varepsilon_{ij}\sim\mathcal{N}(0, \sigma^2)\)
where \(b_1\) represents the overall effect of personality predicting the outcome. For moderator models, we add two additional terms, \(b_2\), which captures the prospective association between a moderator and cognitive ability, adjusting for personality, and b_3, which captures how cognitive ability varies as a function of both personality and the moderator (e.g., does the association differ for males and females).
Models were tested using the lm() function from base R and the tidy() function from the broom package (version 1.0.1; D. Robinson et al., 2022) to extract model coefficients and confidence intervals (CI). Inferences were made based on the 95% confidence intervals. Simple-effects predictions were calculated by providing the full range of personality (0-10) and average levels of the covariates from the data used to estimate the model as the “newdata” argument in the base R predict() function.
3.2.1.2 Model Function
The first thing we need is a function that will bring in the data, create a formula in the model based on input on the type (Frequentist or Bayesian), moderators (none, age, gender, SRhealth, and education), and combinations of covariates (single or fully adjusted based on age, gender, SRhealth, and education). Then we run the model, extract its fixed effect estimates, and save both for later. By saving the results, it will make it easier and faster for us to extract the necessary model results later while still retaining all information from the original model.
ipd1a_mod_fun <- function(trait, outcome, type, mod, cov){
## load the data
load(sprintf("%s/data/one_stage/%s_%s.RData", local_path, trait, outcome))
## model formula
if (cov == "all") cv <- c("age", "gender", "education")
if (!cov %in% c("all", "none")) cv <- cov
rhs <- "p_value"
rhs <- if(cov != "none") c(rhs, cv) else rhs
if(mod != "none"){rhs <- c(rhs, paste("p_value", mod, sep = "*"))}
rhs <- paste(rhs, collapse = " + ")
f <- paste("o_value ~ ", rhs, collapse = "")
## compiled Bayesian model to speed up processing and avoid crashing
if(type == "Bayesian") load(sprintf("%s/results/1a_ipd_reg/bayes_sample_mod.RData", local_path))
## run the models & save
m <- if(type == "Frequentist"){do.call("lm", list(formula = f, data = quote(d)))} else {update(m, formula = f, nelocal_pathata = d, cores = 4)}
save(m, file = sprintf("%s/results/1a_ipd_reg/%s/models/%s_%s_%s_%s.RData", local_path, type, outcome, trait, mod, cov))
## extract model terms and confidence intervals & save
fx <- tidy(m, conf.int = T) %>%
select(term, estimate, conf.low, conf.high)
save(fx, file = sprintf("%s/results/1a_ipd_reg/%s/summary/%s_%s_%s_%s.RData", local_path, type, outcome, trait, mod, cov))
## get simple effects for moderator tests
if(mod != "none"){
pred.fx <- ipd1a_simpeff_fun(m, mod, type)
save(pred.fx, file = sprintf("%s/results/1a_ipd_reg/%s/predicted/%s_%s_%s_%s.RData", local_path, type, outcome, trait, mod, cov))
}
## clean up the local function environment
rm(list = c("d", "f", "rhs", "m", "fx", "cv"))
gc()
}3.2.1.3 Simple Effects Function
ipd1a_simpeff_fun <- function(m, moder, type){
d <- if(type == "Bayesian") m$data else m$model
d <- d %>% select(-o_value, -p_value)
cols <- colnames(d)
md_cl <- class(d[,moder])
if(any(sapply(d, class) == "numeric")){
msd <- d %>%
select_if(is.numeric) %>%
pivot_longer(everything()
, names_to = "item"
, values_to = "value") %>%
group_by(item) %>%
summarize_at(vars(value), lst(mean, sd)) %>%
ungroup()
}
if(any(sapply(d, class) == "factor")){
fct_lev <- d %>%
select_if(is.factor) %>%
summarize_all(~list(unique(.)))
}
d <- d %>% select(-one_of(moder))
md_levs <- if(md_cl == "numeric"){
if(moder %in% c("age", "baseAge", "baseYear")) {
c(-10, 0, 10)
} else if (moder %in% c("predInt", "education")) {
c(-5, 0, 5)
} else {
with(msd, c(mean[item == moder] - sd[item == moder], mean[item == moder], mean[item == moder] + sd[item == moder]))
}
} else {
unique(fct_lev[,moder][[1]])
}
mod_frame <- expand.grid(
p_value = seq(0,10,.5)
, modvalue = md_levs
, stringsAsFactors = F
) %>% setNames(c("p_value", moder))
if(ncol(d) > 0){
if(any(sapply(d, class) == "numeric")){
mod_frame <- tibble(mod_frame, d %>% select_if(is.numeric) %>% summarize_all(mean))
}
if(any(sapply(d, class) == "factor")){
mod_frame <- tibble(mod_frame, d %>% select_if(is.factor) %>% summarize_all(~levels(.)[1]))
}
}
pred.fx <- if(type == "Bayesian"){
bind_cols(
mod_frame,
fitted(m, newdata = mod_frame) %>% data.frame
) %>%
select(one_of(colnames(m$data)), pred = Estimate, lower = Q2.5, upper = Q97.5)
} else {
bind_cols(
mod_frame,
predict(m, newdata = mod_frame, interval = "confidence") %>% data.frame
) %>%
select(one_of(colnames(m$model)), pred = fit, lower = lwr, upper = upr)
}
rm(list = c("m", "mod_frame", "d", "md_levs"))
gc()
return(pred.fx)
}3.2.1.4 Run Models and Summaries
The code below generates all possible preregistrered combinations of traits, outcomes, types, moderators, and covariates. Then these combinations are fed serially to the model function written previously, which will run and save the results.
load(sprintf("%s/data/one_stage/E_crystallized.RData", local_path))
# clean data & keep only needed columns and a subset of the used variables
d <- d %>%
group_by(study) %>%
nest() %>%
ungroup() %>%
mutate(data = map(data, ~(.) %>% filter(row_number() %in% sample(1:nrow(.), 100, replace = F)))) %>%
unnest(data)
# set priors & model specifications
Prior <- c(set_prior("student_t(3, 0, 2)", class = "b"),
set_prior("student_t(3, 0, 5)", class = "Intercept"))
Iter <- 30; Warmup <- 21; treedepth <- 20
f <- bf(o_value ~ p_value + age + gender + education)
m <- brm(formula = f
, data = d
, prior = Prior
, iter = Iter
, warmup = Warmup
, cores = 4)
save(m, file = sprintf("%s/results/1a_ipd_reg/bayes_sample_mod.RData", local_path))
rm(list = c("d", "Prior", "Iter", "Warmup", "treedepth", "f", "m"))plan(multisession(workers = 10L))
nested_ipd1a_reg <-
## moderator combinations
crossing(
Trait = traits$short_name
, Outcome = outcomes$short_name
, type = c("Frequentist", "Bayesian")
, Moderator = c("age", "gender", "education")
, Covariate = c("none", "all")
) %>%
full_join(
# undmoderator combinations
crossing(
Trait = traits$short_name
, Outcome = outcomes$short_name
, type = c("Frequentist", "Bayesian")
, Moderator = c("none", stdyModers$short_name)
, Covariate = c("none", "age", "gender", "education", "all")
)
) %>%
mutate(run =
# pmap(list(Trait, Outcome, type, Moderator, Covariate)
future_pmap(list(Trait, Outcome, type, Moderator, Covariate)
, possibly(ipd1a_mod_fun, "uh-oh")
, .progress = T
, .options = furrr_options(
globals = c("ipd1a_mod_fun"
, "ipd1a_simpeff_fun"
, "read_path"
, "local_path"
, "res_path"
, "codebook"
, "covars"
, "moders"
, "outcomes"
, "studies"
, "stdyModers"
, "traits"
, "data_path")
, packages = c("lme4"
, "broom"
, "psych"
, "knitr"
, "broom.mixed"
, "brms"
#, "tidybayes"
#, "bootpredictlme4"
, "rstan"
, "estimatr"
#, "merTools"
, "plyr"
, "tidyverse"))
)
)
closeAllConnections()3.2.1.5 Compile Results
Once all the models are run, we are ready to compile all their results. By saving the fixed effects results previously, we are able to simply load those results and ignore the models. However, because we also saved the models, we can also recall and extract information from them if and when needed.
loadRData <- function(fileName, type, obj, folder){
# loads an RData file, and returns it
# path <- sprintf("%s/results/1a_ipd_reg/%s/%s/%s", res_path, type, folder, fileName)
path <- sprintf("%s/results/1a_ipd_reg/%s/%s/%s", local_path, type, folder, fileName)
# load(url(path))
load(path)
get(ls()[grepl(obj, ls())])
}
## load in "fixed" effects
## first get file names
nested_ipd1a_reg <- tibble(type = c("Frequentist", "Bayesian")) %>%
mutate(file = map(type, ~list.files(sprintf("%s/results/1a_ipd_reg/%s/summary", local_path, .)))) %>%
unnest(file) %>%
separate(file, c("Outcome", "Trait", "Moderator", "Covariate"), sep = "_", remove = F) %>%
## read in the files
mutate(Covariate = str_remove(Covariate, ".RData"),
fx = map2(file, type, ~loadRData(.x, .y, "fx", "summary"))) %>%
select(-file)
nested_ipd1a_reg## # A tibble: 410 × 6
## type Outcome Trait Moderator Covariate fx
## <chr> <chr> <chr> <chr> <chr> <list>
## 1 Frequentist crystallized A age all <tibble [7 × 4]>
## 2 Frequentist crystallized A age none <tibble [4 × 4]>
## 3 Frequentist crystallized A baseAge age <tibble [5 × 4]>
## 4 Frequentist crystallized A baseAge all <tibble [8 × 4]>
## 5 Frequentist crystallized A baseAge education <tibble [5 × 4]>
## 6 Frequentist crystallized A baseAge gender <tibble [5 × 4]>
## 7 Frequentist crystallized A baseAge none <tibble [4 × 4]>
## 8 Frequentist crystallized A baseYear age <tibble [5 × 4]>
## 9 Frequentist crystallized A baseYear all <tibble [8 × 4]>
## 10 Frequentist crystallized A baseYear education <tibble [5 × 4]>
## # ℹ 400 more rowsAs can be seen above, the resulting data frame is nested, but it can be easily unnested using the unnest() function.
## # A tibble: 2,993 × 9
## type Outcome Trait Moderator Covariate term estimate conf.low conf.high
## <chr> <chr> <chr> <chr> <chr> <chr> <dbl> <dbl> <dbl>
## 1 Frequentist crystallized A age all (Intercept) 5.86 5.70 6.01
## 2 Frequentist crystallized A age all p_value -0.0456 -0.0642 -0.0269
## 3 Frequentist crystallized A age all age 0.0157 0.00510 0.0262
## 4 Frequentist crystallized A age all genderFemale 0.165 0.103 0.228
## 5 Frequentist crystallized A age all SRhealth -0.00315 -0.0203 0.0140
## 6 Frequentist crystallized A age all education 0.260 0.249 0.270
## 7 Frequentist crystallized A age all p_value:age -0.00136 -0.00275 0.0000259
## 8 Frequentist crystallized A age none (Intercept) 7.20 7.07 7.34
## 9 Frequentist crystallized A age none p_value -0.141 -0.158 -0.124
## 10 Frequentist crystallized A age none age 0.00858 -0.00218 0.0193
## # ℹ 2,983 more rows3.2.1.5.1 Tables
3.2.1.5.1.1 Fixed Effects
Next, we want to format the study results in APA table format. In this case, we are interested in the fixed effects of personality predicting cognitive ability when there were no moderators, and the personality x moderator interaction when there was a moderator.
## format results
ipd1a_reg_tab <- nested_ipd1a_reg %>%
unnest(fx) %>%
# keep key terms
filter((Moderator == "none" & term == "p_value") |
(Moderator != "none" & grepl("p_value:", term))) %>%
# mark significance and prettify trait, outcome, and covariate names
mutate(sig = ifelse(sign(conf.low) == sign(conf.high), "sig", "ns"),
Trait = factor(Trait, traits$short_name),
Outcome = factor(Outcome, outcomes$short_name, outcomes$long_name),
Moderator = factor(Moderator, c(moders$short_name, stdyModers$short_name), c(moders$long_name, stdyModers$long_name)),
Covariate = ifelse(Moderator != "None" & Covariate == "None", Moderator, Covariate),
Covariate = factor(Covariate, moders$short_name, str_wrap(moders$long_name, 15)),
term = str_remove_all(term, "p_value:"),
term = mapvalues(term, c("scaleBFIMS", "scaleIPIPNEO", "scaleTDAM40", "countryTheNetherlands")
, c("scaleBFI-S", "scaleIPIP NEO", "scaleTDA-40", "countryThe Netherlands")),
term2 = factor(term, c(moders$short_term, stdyModers$short_term),
c(moders$long_term, stdyModers$long_term))) %>%
# format values as text, combine estimates and CI's, bold significance
mutate_at(vars(estimate, conf.low, conf.high),
~ifelse(abs(.) < .01, sprintf("%.3f", .), sprintf("%.2f", .))) %>%
mutate(est = sprintf("%s<br>[%s, %s]", estimate, conf.low, conf.high),
est = ifelse(sig == "sig", sprintf("<strong>%s</strong>", est), est)) %>%
# mutate(est = sprintf("%s [%s, %s]", estimate, conf.low, conf.high),
# est = ifelse(sig == "sig", sprintf("\\textbf{%s}", est), est)) %>%
# final reshaping, remove extra columns, arrange values, and change to wide format
select(-estimate, -conf.low, -conf.high, -sig, -term) %>%
arrange(type, Outcome, Trait, Moderator, Covariate) %>%
pivot_wider(names_from = "Trait", values_from = "est")
ipd1a_reg_tab## # A tibble: 172 × 10
## type Outcome Moderator Covariate term2 E A C N O
## <chr> <fct> <fct> <fct> <fct> <chr> <chr> <chr> <chr> <chr>
## 1 Bayesian Crystallized Ability None None Personality <strong>-0.08<br>[-… <str… 0.00… -0.1… <str…
## 2 Bayesian Crystallized Ability None Age Personality <strong>-0.09<br>[-… <str… 0.00… 0.09… <str…
## 3 Bayesian Crystallized Ability None Gender Personality <strong>-0.08<br>[-… <str… 0.02… -0.0… <str…
## 4 Bayesian Crystallized Ability None Education Personality <strong>-0.07<br>[-… <str… -0.0… -0.1… <str…
## 5 Bayesian Crystallized Ability None Fully Adjusted Personality <strong>-0.07<br>[-… <str… -0.0… -0.0… <str…
## 6 Bayesian Crystallized Ability Age None Age 0.000<br>[-0.001, 0… -0.0… <str… 0.02… -0.0…
## 7 Bayesian Crystallized Ability Age Fully Adjusted Age 0.000<br>[-0.001, 0… -0.0… -0.0… -0.0… <str…
## 8 Bayesian Crystallized Ability Gender None Gender (Male v Female) <strong>0.07<br>[0.… <str… 0.00… -0.1… -0.0…
## 9 Bayesian Crystallized Ability Gender Fully Adjusted Gender (Male v Female) <strong>0.05<br>[0.… <str… 0.03… -0.0… -0.0…
## 10 Bayesian Crystallized Ability Education None Education (Years) <strong>0.004<br>[0… -0.0… <str… 0.19… 0.00…
## # ℹ 162 more rowsNow that we’ve formatted the values, we can group by moderators and save results as separate tables. Even though additional information could be included given that we have one outcome, we’ll stick with this split because it will make it easier for those using this tutorial who multiple traits, outcomes, covariates, and moderators.
## table function
ipd1a_tab_fun <- function(d, type, moder){
# long outcome name
md <- mapvalues(moder, c(moders$long_name, stdyModers$long_name), c(moders$short_name, stdyModers$short_name), warn_missing = F)
# getting row numbers for later grouping
rs <- d %>% group_by(Outcome) %>% tally() %>%
mutate(end = cumsum(n), start = lag(end) + 1, start = ifelse(is.na(start), 1, start))
# number and name of columns for span columns
cs <- if(length(unique(d$term2)) > 1) c(2, rep(1,5)) else rep(1,6)
names(cs) <- c(" ", traits$long_name)
cln <- if(length(unique(d$term2)) == 1) c("Covariate", rep("\\textit{b} [CI]", 5)) else c(" ", "Term", rep("\\textit{b} [CI]", 5))
cln <- if(length(unique(d$term2)) == 1) c("Covariate", rep("<em>b</em> [CI]", 5)) else c(" ", "Term", rep("<em>b</em> [CI]", 5))
al <- if(length(unique(d$term2)) == 1) c("r", rep("c", 5)) else c("r", "r", rep("c", 5))
if(length(unique(d$term2)) == 1) {
d <- d %>% select(-term2); dubs <- F
}
# caption
cap <- if(md == "none") "1A Pooled Analysis of Individual Participant Data: Fixed Effect Personality-Crystallized Domain Associations" else sprintf("1A Pooled Analysis of Individual Participant Data: Fixed Effect %s Moderation of Personality-Crystallized Domain Associations", md)
# kable the table
tab <- d %>%
select(-Outcome) %>%
kable(., "html"
# kable(., "latex"
, booktabs = T
, escape = F
, col.names = cln
, align = al
, caption = cap
) %>%
kable_classic(full_width = F, html_font = "Times New Roman") %>%
# kable_styling(full_width = F, font_size = 7) %>%
add_header_above(cs)
# for loop to add grouped sections
for (i in 1:nrow(rs)){
tab <- tab %>%
kableExtra::group_rows(rs$Moderator[i], rs$start[i], rs$end[i])
}
# save the resulting html table
save_kable(tab, file = sprintf("%s/results/1a_ipd_reg/%s/tables/overall/%s.html"
, local_path, type, md))
return(tab) # return the html table
}
ipd1a_fx_tab <- ipd1a_reg_tab %>%
group_by(type, Moderator) %>%
nest() %>%
ungroup() %>%
mutate(tab = pmap(list(data, type, Moderator), ipd1a_tab_fun))
ipd1a_reg_tab## # A tibble: 172 × 10
## type Outcome Moderator Covariate term2 E A C N O
## <chr> <fct> <fct> <fct> <fct> <chr> <chr> <chr> <chr> <chr>
## 1 Bayesian Crystallized Ability None None Personality <strong>-0.08<br>[-… <str… 0.00… -0.1… <str…
## 2 Bayesian Crystallized Ability None Age Personality <strong>-0.09<br>[-… <str… 0.00… 0.09… <str…
## 3 Bayesian Crystallized Ability None Gender Personality <strong>-0.08<br>[-… <str… 0.02… -0.0… <str…
## 4 Bayesian Crystallized Ability None Education Personality <strong>-0.07<br>[-… <str… -0.0… -0.1… <str…
## 5 Bayesian Crystallized Ability None Fully Adjusted Personality <strong>-0.07<br>[-… <str… -0.0… -0.0… <str…
## 6 Bayesian Crystallized Ability Age None Age 0.000<br>[-0.001, 0… -0.0… <str… 0.02… -0.0…
## 7 Bayesian Crystallized Ability Age Fully Adjusted Age 0.000<br>[-0.001, 0… -0.0… -0.0… -0.0… <str…
## 8 Bayesian Crystallized Ability Gender None Gender (Male v Female) <strong>0.07<br>[0.… <str… 0.00… -0.1… -0.0…
## 9 Bayesian Crystallized Ability Gender Fully Adjusted Gender (Male v Female) <strong>0.05<br>[0.… <str… 0.03… -0.0… -0.0…
## 10 Bayesian Crystallized Ability Education None Education (Years) <strong>0.004<br>[0… -0.0… <str… 0.19… 0.00…
## # ℹ 162 more rows## Frequentist, no moderator
(ipd1a_fx_tab %>% filter(type == "Frequentist" & Moderator == "None"))$tab[[1]]|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| Covariate | b [CI] | b [CI] | b [CI] | b [CI] | b [CI] |
| None |
-0.08 [-0.10, -0.07] |
-0.14 [-0.16, -0.12] |
0.007 [-0.01, 0.02] |
-0.003 [-0.02, 0.01] |
0.20 [0.19, 0.22] |
| Age |
-0.09 [-0.10, -0.07] |
-0.14 [-0.16, -0.12] |
0.007 [-0.01, 0.02] |
0.002 [-0.01, 0.02] |
0.19 [0.18, 0.21] |
| Gender |
-0.08 [-0.09, -0.06] |
-0.14 [-0.15, -0.12] |
0.02 [-0.001, 0.03] |
0.007 [-0.007, 0.02] |
0.19 [0.17, 0.21] |
| Education |
-0.07 [-0.09, -0.06] |
-0.06 [-0.08, -0.05] |
-0.01 [-0.03, 0.005] |
-0.03 [-0.04, -0.01] |
0.10 [0.09, 0.12] |
| Fully Adjusted |
-0.03 [-0.05, -0.02] |
-0.05 [-0.06, -0.03] |
0.03 [0.02, 0.05] |
-0.03 [-0.04, -0.01] |
0.13 [0.11, 0.14] |
|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| Covariate | b [CI] | b [CI] | b [CI] | b [CI] | b [CI] |
| None |
-0.08 [-0.10, -0.07] |
-0.14 [-0.16, -0.12] |
0.007 [-0.010, 0.02] |
-0.18 [-0.59, 0.18] |
0.20 [0.19, 0.22] |
| Age |
-0.09 [-0.10, -0.07] |
-0.14 [-0.16, -0.12] |
0.007 [-0.01, 0.02] |
0.09 [-0.21, 0.47] |
0.19 [0.18, 0.21] |
| Gender |
-0.08 [-0.09, -0.06] |
-0.14 [-0.15, -0.12] |
0.02 [-0.000, 0.03] |
-0.08 [-0.68, 0.41] |
0.19 [0.17, 0.20] |
| Education |
-0.07 [-0.09, -0.06] |
-0.06 [-0.08, -0.05] |
-0.01 [-0.03, 0.006] |
-0.11 [-0.72, 0.19] |
0.10 [0.09, 0.12] |
| Fully Adjusted |
-0.07 [-0.08, -0.05] |
-0.07 [-0.09, -0.06] |
-0.01 [-0.03, 0.006] |
-0.05 [-0.33, 0.29] |
0.11 [0.09, 0.12] |
ipd1a_tab_fun <- function(d, type, cov){
# long outcome name
covar <- mapvalues(cov, covars$long_name, covars$short_name, warn_missing = F)
# getting row numbers for later grouping
rs <- d %>% group_by(Moderator) %>% tally() %>%
mutate(end = cumsum(n), start = lag(end) + 1, start = ifelse(is.na(start), 1, start))
# number and name of columns for span columns
cs <- rep(1,6)
names(cs) <- c(" ", traits$long_name)
# cln <- if(length(unique(d$term2)) == 1) c("Covariate", rep("\\textit{b} [CI]", 5)) else c(" ", "Term", rep("\\textit{b} [CI]", 5))
cln <- c("Term", rep("<em>b</em> [CI]", 5))
al <- c("r", rep("c", 5))
# caption
cv <- if (cov == "None") "Unadjusted" else cov
cap <- sprintf("1A Pooled Analysis of Individual Participant Data: Fixed Effect Estimates of %s Personality-Crystallized Domain Associations", cv)
# kable the table
tab <- d %>%
select(-Moderator) %>%
kable(., "html"
# kable(., "latex"
, booktabs = T
, escape = F
, col.names = cln
, align = al
, caption = cap
) %>%
kable_classic(full_width = F, html_font = "Times New Roman") %>%
# kable_styling(full_width = F, font_size = 7) %>%
add_header_above(cs)
# for loop to add grouped sections
for (i in 1:nrow(rs)){
tab <- tab %>%
kableExtra::group_rows(rs$Moderator[i], rs$start[i], rs$end[i])
}
# save the resulting html table
save_kable(tab, file = sprintf("%s/results/1a_ipd_reg/%s/tables/key terms/%s.html"
, local_path, type, covar))
return(tab) # return the html table
}
ipd1a_fx_tab2 <- ipd1a_reg_tab %>%
arrange(Outcome, Moderator, term2) %>%
filter(Covariate %in% c("None", "Fully Adjusted")) %>%
group_by(Outcome, type, Covariate) %>%
nest() %>%
ungroup() %>%
mutate(tab = pmap(list(data, type, Covariate), ipd1a_tab_fun))
## Frequentist, no moderator
(ipd1a_fx_tab2 %>% filter(type == "Frequentist" & Covariate == "Fully Adjusted"))$tab[[1]]|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| Term | b [CI] | b [CI] | b [CI] | b [CI] | b [CI] |
| None | |||||
| Personality |
-0.03 [-0.05, -0.02] |
-0.05 [-0.06, -0.03] |
0.03 [0.02, 0.05] |
-0.03 [-0.04, -0.01] |
0.13 [0.11, 0.14] |
| Age | |||||
| Age |
-0.000 [-0.002, 0.001] |
-0.001 [-0.003, 0.000] |
0.001 [-0.001, 0.002] |
0.002 [0.001, 0.003] |
-0.003 [-0.005, -0.002] |
| Gender | |||||
| Gender (Male v Female) |
0.05 [0.02, 0.08] |
0.03 [-0.01, 0.06] |
0.01 [-0.02, 0.05] |
-0.01 [-0.04, 0.01] |
-0.02 [-0.06, 0.009] |
| Education | |||||
| Education (Years) |
0.007 [0.002, 0.01] |
-0.001 [-0.007, 0.005] |
-0.007 [-0.01, -0.001] |
-0.002 [-0.006, 0.001] |
0.005 [-0.000, 0.01] |
| Continent | |||||
| Continent (North America v Europe) |
0.15 [0.10, 0.20] |
-0.03 [-0.09, 0.04] |
-0.04 [-0.10, 0.01] |
0.06 [0.03, 0.09] |
0.04 [-0.01, 0.10] |
| Continent (North America v Australia) |
0.06 [0.02, 0.09] |
0.002 [-0.04, 0.04] |
-0.04 [-0.08, -0.008] |
-0.13 [-0.17, -0.10] |
0.11 [0.08, 0.14] |
| Country | |||||
| Country (United States v Germany) |
0.20 [0.12, 0.27] |
0.005 [-0.08, 0.09] |
-0.06 [-0.15, 0.04] |
0.10 [0.03, 0.17] |
0.02 [-0.04, 0.09] |
| Country (United States v Sweden) |
0.08 [0.02, 0.15] |
-0.22 [-0.33, -0.11] |
-0.21 [-0.30, -0.11] |
0.03 [-0.03, 0.09] |
0.23 [0.09, 0.36] |
| Country (United States v The Netherlands) |
-0.02 [-0.07, 0.03] |
||||
| Country (United States v Australia) |
0.06 [0.02, 0.09] |
0.001 [-0.04, 0.04] |
-0.05 [-0.08, -0.01] |
-0.13 [-0.17, -0.10] |
0.11 [0.08, 0.14] |
| Personality Scale | |||||
| Scale (NEO-FFI v DPQ) |
0.11 [0.06, 0.17] |
||||
| Scale (NEO-FFI v Eysenck) |
0.02 [-0.15, 0.20] |
-0.23 [-0.36, -0.09] |
-0.15 [-0.28, -0.02] |
0.21 [0.14, 0.27] |
-0.06 [-0.25, 0.13] |
| Scale (NEO-FFI v MIDI) |
-0.06 [-0.22, 0.11] |
-0.005 [-0.09, 0.08] |
0.06 [-0.04, 0.15] |
0.14 [0.10, 0.18] |
-0.28 [-0.42, -0.14] |
| Scale (NEO-FFI v BFI-S) |
0.07 [-0.11, 0.25] |
0.14 [0.05, 0.22] |
-0.32 [-0.47, -0.16] |
||
| Scale (NEO-FFI v IPIP NEO) |
0.10 [0.01, 0.19] |
||||
| Scale (NEO-FFI v TDA-40) |
-0.003 [-0.17, 0.16] |
-0.004 [-0.09, 0.08] |
0.01 [-0.08, 0.10] |
0.02 [-0.02, 0.07] |
-0.17 [-0.31, -0.03] |
| Baseline Age | |||||
| Study Baseline Age |
-0.004 [-0.005, -0.003] |
-0.001 [-0.002, 0.001] |
-0.000 [-0.002, 0.001] |
-0.000 [-0.001, 0.001] |
-0.004 [-0.005, -0.003] |
| Baseline Year | |||||
| Study Baseline Year |
-0.003 [-0.006, 0.001] |
0.007 [0.002, 0.01] |
0.007 [0.003, 0.01] |
0.002 [0.000, 0.005] |
-0.010 [-0.01, -0.004] |
| Prediction Interval | |||||
| Prediction Interval |
0.002 [-0.005, 0.009] |
-0.03 [-0.04, -0.03] |
-0.03 [-0.03, -0.02] |
-0.006 [-0.01, -0.000] |
0.02 [0.01, 0.03] |
|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| Term | b [CI] | b [CI] | b [CI] | b [CI] | b [CI] |
| None | |||||
| Personality |
-0.07 [-0.08, -0.05] |
-0.07 [-0.09, -0.06] |
-0.01 [-0.03, 0.006] |
-0.05 [-0.33, 0.29] |
0.11 [0.09, 0.12] |
| Age | |||||
| Age |
0.000 [-0.001, 0.002] |
-0.000 [-0.002, 0.001] |
-0.001 [-0.002, 0.001] |
-0.009 [-0.09, 0.12] |
-0.003 [-0.004, -0.002] |
| Gender | |||||
| Gender (Male v Female) |
0.05 [0.02, 0.08] |
0.04 [0.005, 0.07] |
0.03 [-0.005, 0.06] |
-0.09 [-0.91, 0.44] |
-0.02 [-0.05, 0.01] |
| Education | |||||
| Education (Years) |
0.005 [0.000, 0.009] |
-0.003 [-0.008, 0.001] |
-0.006 [-0.01, -0.002] |
0.10 [-0.11, 0.39] |
0.001 [-0.004, 0.006] |
| Continent | |||||
| Continent (North America v Europe) |
0.26 [0.21, 0.31] |
0.08 [0.02, 0.14] |
0.11 [0.05, 0.17] |
-0.009 [-0.58, 0.26] |
0.08 [0.01, 0.14] |
| Continent (North America v Australia) |
0.18 [0.15, 0.21] |
0.08 [0.05, 0.12] |
0.09 [0.06, 0.13] |
-0.13 [-0.58, 0.36] |
0.13 [0.10, 0.16] |
| Country | |||||
| Country (United States v Germany) |
0.32 [0.24, 0.39] |
0.09 [0.001, 0.18] |
0.08 [-0.01, 0.18] |
0.25 [-0.81, 1.61] |
0.05 [-0.02, 0.12] |
| Country (United States v Sweden) |
0.19 [0.12, 0.26] |
-0.14 [-0.25, -0.03] |
-0.07 [-0.17, 0.04] |
-0.23 [-1.40, 0.61] |
0.24 [0.09, 0.39] |
| Country (United States v The Netherlands) |
1.00 [0.37, 1.69] |
||||
| Country (United States v Australia) |
0.18 [0.15, 0.21] |
0.09 [0.05, 0.12] |
0.09 [0.06, 0.13] |
-0.01 [-0.56, 0.59] |
0.13 [0.10, 0.16] |
| Personality Scale | |||||
| Scale (NEO-FFI v DPQ) |
-0.11 [-1.65, 0.76] |
||||
| Scale (NEO-FFI v Eysenck) |
-0.006 [-0.08, 0.07] |
-0.24 [-0.36, -0.10] |
-0.28 [-0.39, -0.18] |
0.67 [0.34, 0.91] |
0.25 [0.09, 0.40] |
| Scale (NEO-FFI v MIDI) |
-0.07 [-0.11, -0.02] |
-0.007 [-0.08, 0.07] |
-0.05 [-0.11, 0.007] |
0.16 [-0.26, 0.54] |
0.04 [-0.03, 0.11] |
| Scale (NEO-FFI v BFI-S) |
0.05 [-0.04, 0.14] |
-0.01 [-0.13, 0.10] |
-0.14 [-0.24, -0.03] |
0.20 [-1.47, 1.79] |
-0.007 [-0.10, 0.09] |
| Scale (NEO-FFI v IPIP NEO) |
0.04 [-0.06, 0.14] |
0.01 [-0.10, 0.12] |
-0.18 [-0.28, -0.09] |
-0.02 [-1.12, 1.58] |
0.12 [0.02, 0.23] |
| Scale (NEO-FFI v TDA-40) |
-0.02 [-0.07, 0.03] |
-0.01 [-0.09, 0.07] |
-0.11 [-0.17, -0.05] |
-0.06 [-0.81, 0.63] |
0.13 [0.06, 0.21] |
| Baseline Age | |||||
| Study Baseline Age |
-0.006 [-0.007, -0.005] |
-0.003 [-0.004, -0.002] |
-0.005 [-0.007, -0.004] |
-0.06 [-0.19, 0.000] |
-0.005 [-0.006, -0.004] |
| Baseline Year | |||||
| Study Baseline Year |
-0.005 [-0.008, -0.002] |
0.01 [0.007, 0.02] |
-0.003 [-0.007, 0.001] |
-0.07 [-0.16, 0.009] |
0.001 [-0.004, 0.006] |
| Prediction Interval | |||||
| Prediction Interval |
0.009 [0.003, 0.02] |
-0.03 [-0.03, -0.02] |
-0.01 [-0.02, -0.006] |
-0.05 [-0.29, 0.92] |
0.003 [-0.005, 0.01] |
3.2.1.5.1.2 Study-Specific Effects
This header is here to simply emphasize that this method does not provide study-specific estimates, unlike Methods 2ab, 3, and 4.
3.2.1.5.1.3 Heterogeneity Estimates
This header is here to simply emphasize that this method does not provide heterogeneity estimates because it does not provide study-specific estimates, unlike Methods 2ab, 3, and 4.
3.2.1.5.1.4 All Model Terms
ipd1a_mod_tab <- nested_ipd1a_reg %>%
unnest(fx) %>%
# keep key terms
# mark significance and prettify trait, outcome, and covariate names
mutate(sig = ifelse(sign(conf.low) == sign(conf.high), "sig", "ns"),
Trait = factor(Trait, traits$short_name),
Outcome = factor(Outcome, outcomes$short_name, outcomes$long_name),
Moderator = factor(Moderator, c(moders$short_name, stdyModers$short_name), c(moders$long_name, stdyModers$long_name)),
Covariate = factor(Covariate, covars$short_name, str_wrap(covars$long_name, 15)),#ifelse(Moderator != "None" & Covariate == "none", Moderator, Covariate),
) %>%
# format values as text, combine estimates and CI's, bold significance
mutate_at(vars(estimate, conf.low, conf.high),
~ifelse(abs(.) < .01, sprintf("%.3f", .), sprintf("%.2f", .))) %>%
mutate(est = sprintf("%s<br>[%s, %s]", estimate, conf.low, conf.high),
est = ifelse(sig == "sig", sprintf("<strong>%s</strong>", est), est)) %>%
# mutate(est = sprintf("%s [%s, %s]", estimate, conf.low, conf.high),
# est = ifelse(sig == "sig", sprintf("\\textbf{%s}", est), est)) %>%
# final reshaping, remove extra columns, arrange values, and change to wide format
select(-estimate, -conf.low, -conf.high, -sig) %>%
arrange(type, Outcome, Trait, Moderator, Covariate) %>%
pivot_wider(names_from = "Trait", values_from = "est")
ipd1a_mod_tab_fun <- function(d, type, out, moder, cov){
md <- mapvalues(moder, c(moders$long_name, stdyModers$long_name), c(moders$short_name, stdyModers$short_name), warn_missing = F)
o <- mapvalues(out, outcomes$long_name, outcomes$short_name, warn_missing = F)
cv <- mapvalues(cov, covars$long_name, covars$short_name, warn_missing = F)
cs <- rep(1,6)
names(cs) <- c(" ", traits$long_name)
# cln <- if(length(unique(d$term2)) == 1) c("Covariate", rep("\\textit{b} [CI]", 5)) else c(" ", "Term", rep("\\textit{b} [CI]", 5))
cln <- c("Term", rep("<em>b</em> [CI]", 5))
al <- c("r", rep("c", 5))
# caption
cap <- if(md == "none") "1A Pooled Analysis of Individual Participant Data: All Model Estimates of Fixed Effect Personality-Crystallized Domain Associations" else sprintf("1A Pooled Analysis of Individual Participant Data: All Model Estimates of Fixed Effect %s Moderation of Personality-Crystallized Domain Associations", md)
# kable the table
tab <- d %>%
arrange(term) %>%
kable(., "html"
# kable(., "latex"
, booktabs = T
, escape = F
, col.names = cln
, align = al
, caption = cap
) %>%
kable_classic(full_width = F, html_font = "Times New Roman") %>%
# kable_styling(full_width = F, font_size = 7) %>%
add_header_above(cs)
# save the resulting html table
save_kable(tab, file = sprintf("%s/results/1a_ipd_reg/%s/tables/all terms/%s-%s-%s.html"
, local_path, type, o, md, cv))
return(tab) # return the html table
}
ipd1a_mod_tab <- ipd1a_mod_tab %>%
group_by(type, Outcome, Moderator, Covariate) %>%
nest() %>%
ungroup() %>%
mutate(tab = pmap(list(data, type, Outcome, Moderator, Covariate), ipd1a_mod_tab_fun))3.2.1.5.2 Figures
3.2.1.5.2.1 Overall Forest
ipd1a_fx_plot_fun <- function(df, mod, type, cov){
m <- mapvalues(mod, c(moders$short_name, stdyModers$short_name), c(moders$long_name, stdyModers$long_name), warn_missing = F)
cv <- mapvalues(cov, covars$short_name, covars$long_name, warn_missing = F)
dl <- round(max(abs(min(df$estimate)), abs(max(df$estimate))), 3)
# stds <- unique(df$study)
lim <- c(0-dl-(dl/2.5), 0+dl+(dl/2.5))
brk <- if(dl > .01) round(c(0-dl-(dl/5), 0, 0+dl+(dl/5)),2) else round(c(0-dl-(dl/5), 0, 0+dl+(dl/5)),3)
# lim_high <- lim[2]*4
lab <- str_replace(brk, "^0.", ".")#str_remove(round(c(0-d-(d/5), 0, 0+d+(d/5)),2), "^0")
shapes <- c(15, 16, 17, 18)[1:length(unique(df$term))]
lt <- rep("solid", length(unique(df$term)))
titl <- if(mod == "none"){NULL} else {sprintf("%s Moderation of Personality-Outcome Associations", m)}
titl <- if(!cov %in% c("none", "all")) paste(cv, "Adjusted", titl, collapse = " ") else paste(cv, titl, collapse = " ")
leg <- if(length(unique(df$term)) > 1){"bottom"} else {"none"}
p <- df %>%
mutate(conf.low = ifelse(conf.low < lim[1], lim[1], conf.low),
conf.high = ifelse(conf.high > lim[2], lim[2], conf.high)) %>%
ggplot(aes(x = Outcome, y = estimate)) +
scale_y_continuous(limits = lim, breaks = brk, labels = lab) +
scale_size_manual(values = c(2, 1.5)) +
scale_shape_manual(values = shapes) +
scale_color_manual(values = c("blue", "black")) +
scale_linetype_manual(values = lt) +
geom_hline(aes(yintercept = 0), size = .5, linetype = "dashed") +
geom_errorbar(aes(ymin = conf.low, ymax = conf.high, linetype = term)
, width = 0
, position = position_dodge(width = .9)) +
geom_point(aes(color = sig, size = sig, shape = term)
, position = position_dodge(width = .9)) +
labs(x = NULL
, y = "Estimate (POMP)"
, title = titl
, subtitle = "Method 1A: Pooled Simple Linear Regression"
, term = "Term"
) +
guides(color = "none", size = "none") +
facet_grid(~Trait, scales = "free_y", space = "free") +
coord_flip() +
theme_classic() +
theme(legend.position = leg,
plot.title = element_text(face = "bold", size = rel(1.2), hjust = .5),
plot.subtitle = element_text(hjust = .5),
panel.background = element_rect(color = "black", fill = "white"),
strip.background = element_blank(),
strip.text = element_text(face = "bold", color = "black", size = rel(1.4)),
axis.text = element_text(color = "black"),
axis.text.y = element_text(size = rel(1)))
ht <- length(unique(df$Outcome)); ht2 <- length(unique(df$term))
wdt <- length(unique(df$Trait))
ggsave(file = sprintf("%s/results/1a_ipd_reg/%s/figures/overall forest/%s_%s_fixed.png", local_path, type, mod, cov), width = wdt*2, height = ht + ht2)
# save(p, file = sprintf("%s/results/ipd1a_reg/%s/figures/overall forest/rdata/%s_fixed.RData", type, local_path, mod))
rm(p)
gc()
return(T)
}
# x1 = 1, x2 = 1, y = 2
# x1 = 1, x2 = 2, y = 3
ipd1a_fp <- nested_ipd1a_reg %>%
unnest(fx) %>%
filter((Moderator == "none" & term == "p_value")|
(Moderator != "none" & grepl("p_value:", term))) %>%
mutate(sig = ifelse(sign(conf.low) == sign(conf.high), "sig", "ns"),
sig = factor(sig, levels = c("sig","ns")),
Trait = factor(Trait, levels = traits$short_name),
Outcome = factor(Outcome, levels = outcomes$short_name, labels = str_wrap(outcomes$long_name, 15)),
Outcome = forcats::fct_rev(Outcome)) %>%
group_by(type, Moderator, Covariate) %>%
nest() %>%
ungroup() %>%
mutate(pmap(list(data, Moderator, type, Covariate), ipd1a_fx_plot_fun))3.2.1.5.2.2 Study-Specific Forest Plots
This header is here to simply emphasize that this method does not provide study-specific estimates, unlike Methods 2ab, 3, and 4.
3.2.1.5.2.3 Overall Simple Effects Plots
loadRData <- function(fileName, type, obj, folder){
#loads an RData file, and returns it
path <- sprintf("%s/results/1a_ipd_reg/%s/%s/%s", local_path, type, folder, fileName)
load(path)
get(ls()[grepl(obj, ls())])
}
## load in "fixed" effects
## first get file names
nested_ipd1a_simp <- tibble(type = c("Frequentist", "Bayesian")) %>%
mutate(file = map(type, ~list.files(sprintf("%s/results/1a_ipd_reg/%s/predicted", local_path, .)))) %>%
unnest(file) %>%
separate(file, c("Outcome", "Trait", "Moderator", "Covariate"), sep = "_", remove = F) %>%
## read in the files
mutate(Covariate = str_remove(Covariate, ".RData"),
pred = map2(file, type, ~loadRData(.x, .y, "pred.fx", "predicted"))) %>%
select(-file)
nested_ipd1a_simp## # A tibble: 360 × 6
## type Outcome Trait Moderator Covariate pred
## <chr> <chr> <chr> <chr> <chr> <list>
## 1 Frequentist crystallized A age all <tibble [63 × 8]>
## 2 Frequentist crystallized A age none <df [63 × 5]>
## 3 Frequentist crystallized A baseAge age <tibble [63 × 6]>
## 4 Frequentist crystallized A baseAge all <tibble [63 × 9]>
## 5 Frequentist crystallized A baseAge education <tibble [63 × 6]>
## 6 Frequentist crystallized A baseAge gender <tibble [63 × 6]>
## 7 Frequentist crystallized A baseAge none <df [63 × 5]>
## 8 Frequentist crystallized A baseYear age <tibble [63 × 6]>
## 9 Frequentist crystallized A baseYear all <tibble [63 × 9]>
## 10 Frequentist crystallized A baseYear education <tibble [63 × 6]>
## # ℹ 350 more rows3.2.1.5.2.4 Study-Specific Simple Effects Plots
This header is here to simply emphasize that this method does not provide study-specific estimates, unlike Methods 2ab, 3, and 4.
simp_eff_fun <- function(df, outcome, mod, type, cov){
print(paste(outcome, mod))
o <- mapvalues(outcome, outcomes$short_name, outcomes$long_name, warn_missing = F)
cv <- mapvalues(cov, covars$short_name, covars$long_name, warn_missing = F)
m <- mapvalues(mod, c(moders$short_name, stdyModers$short_name), c(moders$long_name, stdyModers$long_name), warn_missing = F)
d <- round(max(abs(min(df$pred)), abs(max(df$pred))), 3)
mini <- if(d > 2) .05 else 0-(d+(d/5))
maxi <- if(d > 2) 2.05 else 0+d+(d/5)
lim <- c(mini, maxi)
brk <- if(d > 2) c(0, 1, 2) else{round(c(0-d-(d/10), 0, 0+d+(d/10)),2)}
lab <- if(d > 2){c("0", "1", "2")} else{str_remove(c(round(0-d-(d/10),2), 0, round(0+d+(d/10),2)), "^0")}
titl <- if(mod == "none"){o} else {sprintf("%s: Personality x %s Simple Effects", o, m)}
# colnames(df)[colnames(df) == mod] <- "mod_value"
df <- df %>% unclass %>% data.frame
df$mod_value <- df[,mod]
df <- df %>% select(-all_of(mod)) %>% as_tibble
if(class(df$mod_value) == "factor"){df <- df %>% mutate(mod_fac = factor(mod_value))}
else{df <- df %>%
group_by(Trait) %>%
mutate(mod_fac = factor(mod_value, levels = unique(mod_value), labels = c("-1 SD", "M", "+1 SD"))) %>%
ungroup()
}
lt <- c("dotted", "solid", "dashed", "dotdash", "longdash", "twodash")[1:length(unique(df$mod_fac))]
df %>%
mutate(Trait = factor(Trait, levels = traits$short_name, labels = traits$long_name),
lower = ifelse(lower < 4, 4, lower),
upper = ifelse(upper > 10, 10, upper)) %>%
ggplot(aes(x = p_value
, y = pred
, group = mod_fac)) +
scale_y_continuous(limits = c(4,10)
, breaks = c(4, 6, 8, 10)
, labels = c(4, 6, 8, 10)) +
scale_linetype_manual(values = lt) +
geom_ribbon(aes(ymin = lower
, ymax = upper
, fill = mod_fac)
, alpha = .25) +
geom_line(aes(linetype = mod_fac)) +
labs(x = "Personality (POMP)"
, y = paste(o, "(POMP)")
, title = titl
, linetype = m
, fill = m
, subtitle = "Method 1A: Pooled Simple Linear Regression") +
facet_wrap(~Trait, nrow = 3) +
theme_classic() +
theme(legend.position = "bottom"
, plot.title = element_text(face = "bold", size = rel(1.2), hjust = .5)
, plot.subtitle = element_text(hjust = .5)
, strip.background = element_rect(fill = "black")
, strip.text = element_text(face = "bold", color = "white")
, axis.text = element_text(color = "black"))
ggsave(file = sprintf("%s/results/1a_ipd_reg/%s/figures/overall simple effects/%s_%s_%s.png", local_path, type, outcome, mod, cov), width = 6, height = 6)
}
ipd1a_se_plot <- nested_ipd1a_simp %>%
group_by(type, Outcome, Moderator, Covariate) %>%
nest() %>%
ungroup() %>%
mutate(data = map(data, ~(.) %>% unnest(pred)),
plot = pmap(list(data, Outcome, Moderator, type, Covariate), simp_eff_fun))## [1] "crystallized age"## [1] "crystallized age"## [1] "crystallized baseAge"## [1] "crystallized baseAge"## [1] "crystallized baseAge"## [1] "crystallized baseAge"## [1] "crystallized baseAge"## [1] "crystallized baseYear"## [1] "crystallized baseYear"## [1] "crystallized baseYear"## [1] "crystallized baseYear"## [1] "crystallized baseYear"## [1] "crystallized continent"## [1] "crystallized continent"## [1] "crystallized continent"## [1] "crystallized continent"## [1] "crystallized continent"## [1] "crystallized country"## [1] "crystallized country"## [1] "crystallized country"## [1] "crystallized country"## [1] "crystallized country"## [1] "crystallized education"## [1] "crystallized education"## [1] "crystallized gender"## [1] "crystallized gender"## [1] "crystallized predInt"## [1] "crystallized predInt"## [1] "crystallized predInt"## [1] "crystallized predInt"## [1] "crystallized predInt"## [1] "crystallized scale"## [1] "crystallized scale"## [1] "crystallized scale"## [1] "crystallized scale"## [1] "crystallized scale"## [1] "crystallized age"## [1] "crystallized age"## [1] "crystallized baseAge"## [1] "crystallized baseAge"## [1] "crystallized baseAge"## [1] "crystallized baseAge"## [1] "crystallized baseAge"## [1] "crystallized baseYear"## [1] "crystallized baseYear"## [1] "crystallized baseYear"## [1] "crystallized baseYear"## [1] "crystallized baseYear"## [1] "crystallized continent"## [1] "crystallized continent"## [1] "crystallized continent"## [1] "crystallized continent"## [1] "crystallized continent"## [1] "crystallized country"## [1] "crystallized country"## [1] "crystallized country"## [1] "crystallized country"## [1] "crystallized country"## [1] "crystallized education"## [1] "crystallized education"## [1] "crystallized gender"## [1] "crystallized gender"## [1] "crystallized predInt"## [1] "crystallized predInt"## [1] "crystallized predInt"## [1] "crystallized predInt"## [1] "crystallized predInt"## [1] "crystallized scale"## [1] "crystallized scale"## [1] "crystallized scale"## [1] "crystallized scale"## [1] "crystallized scale"# Extraversion continent
load("~/Documents/projects/data synthesis/crystallized/results/1a_ipd_reg/Frequentist/models/crystallized_E_continent_all.RData")
coef(m)## (Intercept) p_value age genderFemale
## 5.549134520 -0.046145461 0.004171313 0.141786850
## SRhealth education continentAustralia continentEurope
## 0.019022604 0.308632325 -0.485469914 1.179707965
## p_value:continentAustralia p_value:continentEurope
## 0.057715148 0.150113337cntrm <- c(
"p_value = 0" # North America
, "p_value + p_value:continentAustralia = 0" # Australia
, "p_value + p_value:continentEurope = 0" # Europe
); names(cntrm) <- c("North America", "Australia", "Europe")
(multcomp::glht(m, cntrm) %>% # multcomp hypothesis function
confint(., calpha = multcomp::univariate_calpha()))$confint %>%
data.frame() %>%
data.frame() %>%
rownames_to_column("cntr") %>%
mutate(term = mapvalues(cntr, str_remove(cntrm, " = 0"), names(cntrm))) %>%
select(-cntr) %>%
mutate(est = sprintf("b = %.2f, 95%% CI [%.2f, %.2f]", Estimate, lwr, upr))## Estimate lwr upr term est
## 1 -0.04614546 -0.06939046 -0.02290047 North America b = -0.05, 95% CI [-0.07, -0.02]
## 2 0.01156969 -0.01240456 0.03554393 Australia b = 0.01, 95% CI [-0.01, 0.04]
## 3 0.10396788 0.05998319 0.14795256 Europe b = 0.10, 95% CI [0.06, 0.15]# Neuroticism continent
load("~/Documents/projects/data synthesis/crystallized/results/1a_ipd_reg/Frequentist/models/crystallized_N_continent_all.RData")
coef(m)## (Intercept) p_value age genderFemale
## 5.9846147217 -0.0019269944 -0.0003912502 -0.1545757888
## education continentAustralia continentEurope p_value:continentAustralia
## 0.3065055260 -0.1803310763 1.1872866354 -0.1332956492
## p_value:continentEurope
## 0.0611509497cntrm <- c(
"p_value = 0" # North America
, "p_value + p_value:continentAustralia = 0" # Australia
, "p_value + p_value:continentEurope = 0" # Europe
); names(cntrm) <- c("North America", "Australia", "Europe")
(multcomp::glht(m, cntrm) %>% # multcomp hypothesis function
confint(., calpha = multcomp::univariate_calpha()))$confint %>%
data.frame() %>%
data.frame() %>%
rownames_to_column("cntr") %>%
mutate(term = mapvalues(cntr, str_remove(cntrm, " = 0"), names(cntrm))) %>%
select(-cntr) %>%
mutate(est = sprintf("b = %.2f, 95%% CI [%.2f, %.2f]", Estimate, lwr, upr))## Estimate lwr upr term est
## 1 -0.001926994 -0.02067998 0.01682599 North America b = -0.00, 95% CI [-0.02, 0.02]
## 2 -0.135222644 -0.16119743 -0.10924786 Australia b = -0.14, 95% CI [-0.16, -0.11]
## 3 0.059223955 0.03262787 0.08582004 Europe b = 0.06, 95% CI [0.03, 0.09]# Neuroticism continent
load("~/Documents/projects/data synthesis/crystallized/results/1a_ipd_reg/Frequentist/models/crystallized_O_scale_all.RData")
coef(m)## (Intercept) p_value age genderFemale SRhealth
## 3.339901072 0.368662547 0.006242933 0.160535249 0.037314257
## education scaleBFI-S scaleEysenck scaleMIDI scaleTDA-40
## 0.271069104 4.327067799 2.644895382 1.206799564 0.684281664
## p_value:scaleBFI-S p_value:scaleEysenck p_value:scaleMIDI p_value:scaleTDA-40
## -0.316552453 -0.059001287 -0.281742471 -0.172583588cntrm <- rbind(
c(0,1,rep(0,12)) # NEO-FFI
, c(0,1,rep(0,8),1,rep(0,3)) # BFI-S
, c(0,1,rep(0,9),1,rep(0,2)) # Eysenck
, c(0,1,rep(0,10),1,0) # MIDI
, c(0,1,rep(0,11),1) # TDA-40
); rownames(cntrm) <- c("NEO-FFI", "BFI-S", "Eysenck", "MIDI", "TDA-40")
(multcomp::glht(m, cntrm) %>% # multcomp hypothesis function
confint(., calpha = multcomp::univariate_calpha()))$confint %>%
data.frame() %>%
data.frame() %>%
rownames_to_column("cntr") %>%
mutate(term = rownames(cntrm)) %>%
select(-cntr) %>%
mutate(est = sprintf("b = %.2f, 95%% CI [%.2f, %.2f]", Estimate, lwr, upr))## Estimate lwr upr term est
## 1 0.36866255 0.22956598 0.5077591 NEO-FFI b = 0.37, 95% CI [0.23, 0.51]
## 2 0.05211009 -0.01683090 0.1210511 BFI-S b = 0.05, 95% CI [-0.02, 0.12]
## 3 0.30966126 0.17573543 0.4435871 Eysenck b = 0.31, 95% CI [0.18, 0.44]
## 4 0.08692008 0.06461337 0.1092268 MIDI b = 0.09, 95% CI [0.06, 0.11]
## 5 0.19607896 0.17193054 0.2202274 TDA-40 b = 0.20, 95% CI [0.17, 0.22]3.2.1.6 Sample Results Section
We examined estimates of overall prospective associations between Big Five personality characteristics and crystallized abilities as well as participant and sample-level moderators of those associations using fully pooled, one-stage regression models with individual participant data in 11 studies. Table S1 presents the fully adjusted (age, gender, education) pooled estimates of the key terms from all unmoderated estimates as well as participant- and sample-level moderators. Across the 20 (5 unmoderated, 15 participant-level moderators) key participant-level terms, 10 (50%) were significant. For unmoderated personality-cognition associations, extraversion (-), agreeableness (-), conscientiousness (+), neuroticism (-), and openness (+) were significantly associated with later crystallized abilities. Forest plots of the overall point estimates are available in the online materials and web app, as are tables with all model terms (e.g., intercepts, covariate-cognitive ability associations).
|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| Term | b [CI] | b [CI] | b [CI] | b [CI] | b [CI] |
| None | |||||
| Personality |
-0.03 [-0.05, -0.02] |
-0.05 [-0.06, -0.03] |
0.03 [0.02, 0.05] |
-0.03 [-0.04, -0.01] |
0.13 [0.11, 0.14] |
| Age | |||||
| Age |
-0.000 [-0.002, 0.001] |
-0.001 [-0.003, 0.000] |
0.001 [-0.001, 0.002] |
0.002 [0.001, 0.003] |
-0.003 [-0.005, -0.002] |
| Gender | |||||
| Gender (Male v Female) |
0.05 [0.02, 0.08] |
0.03 [-0.01, 0.06] |
0.01 [-0.02, 0.05] |
-0.01 [-0.04, 0.01] |
-0.02 [-0.06, 0.009] |
| Education | |||||
| Education (Years) |
0.007 [0.002, 0.01] |
-0.001 [-0.007, 0.005] |
-0.007 [-0.01, -0.001] |
-0.002 [-0.006, 0.001] |
0.005 [-0.000, 0.01] |
| Continent | |||||
| Continent (North America v Europe) |
0.15 [0.10, 0.20] |
-0.03 [-0.09, 0.04] |
-0.04 [-0.10, 0.01] |
0.06 [0.03, 0.09] |
0.04 [-0.01, 0.10] |
| Continent (North America v Australia) |
0.06 [0.02, 0.09] |
0.002 [-0.04, 0.04] |
-0.04 [-0.08, -0.008] |
-0.13 [-0.17, -0.10] |
0.11 [0.08, 0.14] |
| Country | |||||
| Country (United States v Germany) |
0.20 [0.12, 0.27] |
0.005 [-0.08, 0.09] |
-0.06 [-0.15, 0.04] |
0.10 [0.03, 0.17] |
0.02 [-0.04, 0.09] |
| Country (United States v Sweden) |
0.08 [0.02, 0.15] |
-0.22 [-0.33, -0.11] |
-0.21 [-0.30, -0.11] |
0.03 [-0.03, 0.09] |
0.23 [0.09, 0.36] |
| Country (United States v The Netherlands) |
-0.02 [-0.07, 0.03] |
||||
| Country (United States v Australia) |
0.06 [0.02, 0.09] |
0.001 [-0.04, 0.04] |
-0.05 [-0.08, -0.01] |
-0.13 [-0.17, -0.10] |
0.11 [0.08, 0.14] |
| Personality Scale | |||||
| Scale (NEO-FFI v DPQ) |
0.11 [0.06, 0.17] |
||||
| Scale (NEO-FFI v Eysenck) |
0.02 [-0.15, 0.20] |
-0.23 [-0.36, -0.09] |
-0.15 [-0.28, -0.02] |
0.21 [0.14, 0.27] |
-0.06 [-0.25, 0.13] |
| Scale (NEO-FFI v MIDI) |
-0.06 [-0.22, 0.11] |
-0.005 [-0.09, 0.08] |
0.06 [-0.04, 0.15] |
0.14 [0.10, 0.18] |
-0.28 [-0.42, -0.14] |
| Scale (NEO-FFI v BFI-S) |
0.07 [-0.11, 0.25] |
0.14 [0.05, 0.22] |
-0.32 [-0.47, -0.16] |
||
| Scale (NEO-FFI v IPIP NEO) |
0.10 [0.01, 0.19] |
||||
| Scale (NEO-FFI v TDA-40) |
-0.003 [-0.17, 0.16] |
-0.004 [-0.09, 0.08] |
0.01 [-0.08, 0.10] |
0.02 [-0.02, 0.07] |
-0.17 [-0.31, -0.03] |
| Baseline Age | |||||
| Study Baseline Age |
-0.004 [-0.005, -0.003] |
-0.001 [-0.002, 0.001] |
-0.000 [-0.002, 0.001] |
-0.000 [-0.001, 0.001] |
-0.004 [-0.005, -0.003] |
| Baseline Year | |||||
| Study Baseline Year |
-0.003 [-0.006, 0.001] |
0.007 [0.002, 0.01] |
0.007 [0.003, 0.01] |
0.002 [0.000, 0.005] |
-0.010 [-0.01, -0.004] |
| Prediction Interval | |||||
| Prediction Interval |
0.002 [-0.005, 0.009] |
-0.03 [-0.04, -0.03] |
-0.03 [-0.03, -0.02] |
-0.006 [-0.01, -0.000] |
0.02 [0.01, 0.03] |
In addition, gender (b = 0.05, 95% CI [0.02, 0.08]) moderated the prospective association between extraversion and crystallized abilities. To better understand how gender moderates the relationships, Figure S1 displays the fully adjusted (age, gender, education) predicted crystallized abilities levels at different levels of the Big Five for males and females. As is clear in the first column (Method 1A) and first row (extraversion) of the figure, the overall prospective association between personality-crystallized ability association was negative for males (b = -0.06, 95% CI [-0.08, -0.04]) and null for females (b = -0.01, 95% CI [-0.03, 0.006]). Moreover, education moderated the association between extraversion (b = 0.007, 95% CI [0.002, 0.01]) and conscientiousness (b = -0.007, 95% [-0.01, -0.001]) and later crystallized abilities. For extraversion, this indicated that less educated individuals who were higher in extraversion tended to have lower crystallized ability scores at later time points than those with more education and high in extraversion. For conscientiousness, less educated individuals who were lower in conscientiousness had worse crystallized ability at later time points than more educated individuals who were lower in conscientiousness. Finally, age moderated the relationship between both neuroticism (b = 0.002, 95% CI [0.001, 0.003]) and openness (b = -0.003, 95% CI [-0.005, -0.002]) and crystallized abilities. Older individuals who were higher in neuroticism had higher crystallized ability scores than younger individuals. Older individuals who were lower in openness had higher crystallized ability scores than younger individuals who were low in openness. All other simple effects of participant-level moderators are available in the online materials and in the web app.
Figure 3.1: Figure S1. Simple effects of the prospective association between Big Five personality characteristics (rows) and crystallized abilities across gender (male, female) using all methods of data synthesis (columns). The x-axis captures personality in percentage of maximum possible (POMP) units, the y-axis captures crystallized abilities in POMP, and different panels represent each of the Big Five characteristics. Different lines indicate the predicted levels of cognitive ability for males (dotted line) and females (solid line).
Additionally, we examined sample-level moderators. These moderators are those that are the same across the individuals in the sample and speak more to similarities and differences in the samples as a whole. Specifically, we examined how the continent and country of origin of each sample, the personality scale used, the average baseline age of the sample, the average baseline year of assessment of personality, and the average interval between personality and cognitive assessment may predict the estimated personality-cognitive ability association. Estimates of the sample-level moderators of Big Five personality characteristic-crystallized / knowledge domain cognitive ability associations across methods can be seen in Table S1. Of these 55 tested associations, 36 (65.45%) were significant. For example, the associations between both extraversion and neuroticism and crystallized / knowledge domain associations were more positive for European and Australian samples than for North American samples. Although North American samples (b = -0.05, 95% CI [-0.07, -0.02]) demonstrated negative associations between extraversion and cognitive ability, European samples (b = 0.06, 95% CI [0.06, 0.15]) demonstrated positive associations, and Australian samples (b = 0.01, 95% CI [-0.01, 0.04]) null associations. For neuroticism, North American samples (b = -0.01, 95% CI [-0.02, 0.02]) demonstrated null associations with cognitive ability, while European (b = 0.06, 95% CI [0.03, 0.09]) samples demonstrated a positive association and Australian samples (b = -0.14, 95% CI [-0.16, -0.11]) demonstrated a negative association. For personality scales, NEO-FFI measures of openness (b = 0.37, 95% CI [0.23, 0.51]) tended to be differently associated with crystallized / knowledge domain cognitive ability than other personality scales, including the MIDI (HRS, b = 0.09, 95% CI [0.06, 0.11]), the BFI-S (GSOEP, b = 0.05, 95% CI [-0.02, 0.12]), and the TDA-40 (HILDA, b = 0.20, 95% CI [0.17, 0.22]).
3.2.2 Part 1B: Pooled Linear Regression with Cluster Robust Standard Errors
3.2.2.1 Analytic Plan
In the present study, we aimed to examine associations between personality traits and crystallized cognitive abilities using fully pooled, single-stage regression models with cluster robust standard errors (Gaure, 2013; Pustejovsky & Tipton, 2018) and individual participant data. Correcting for dependencies without explicitly modeling cross-sample heterogeneity is sometimes called nuisance clustering (Fitzmaurice & Laird, 1995). Below, we detail each stage of the analysis.
3.2.2.1.1 Statistical Modeling
A single regression model tests the relationship between personality and crystallized cognitive ability across all samples. Using the R programming language, we created two functions to (1) set up and run the model and extract model coefficients and (2) extract simple-effects predictions for moderator models (i.e. predicted values across levels of the moderator values). The basic form of the model is as follows:
\(Y_{ij}=b_0+b_1\ast predictor_{ij}+\epsilon_{ij}\) \(\varepsilon_{ij}\sim\mathcal{N}(0, \sigma^2)\),
with sample as a cluster, where \(b_1\) represents the overall effect of personality predicting the outcome. For moderator models, we add two additional terms, \(b_2\), which captures the prospective association between a moderator and cognitive ability, adjusting for personality, and b_3, which captures how cognitive ability varies as a function of both personality and the moderator (e.g., does the association differ for males and females).
Models will be tested using the lm_robust() function from the estimatr package in R, with cluster=study and se_type="CR0". The tidy() function from the broom package was used to extract model coefficients and confidence intervals (CI). Inferences will be based on the 95% confidence intervals. Simple-effects predictions were calculated by providing the full range of personality (0-10) and average levels of the covariates from the data used to estimate the model as the “newdata” argument in the predict() function.
3.2.2.2 Model Function
The first thing we need is a function that will bring in the data, create a formula in the model based on input on the type (Frequentist or Bayesian), moderators (none, age, gender, and education), and combinations of covariates (single or fully adjusted based on age, gender, and education). Then we run the model, which in this case uses the lm_robust() function from the estimatr pacakge, extract its fixed effect estimates, and save both for later. By saving the results, it will make it easier and faster for us to extract the necessary model results later while still retaining all information from the original model.
ipd1b_mod_fun <- function(trait, outcome, type, mod, cov){
## load the data
load(sprintf("%s/data/one_stage/%s_%s.RData", local_path, trait, outcome))
## model formula
if (cov == "all") cv <- c("age", "gender", "education")
if (!cov %in% c("all", "none")) cv <- cov
rhs <- "p_value"
rhs <- if(cov != "none") c(rhs, cv) else rhs
if(mod != "none"){rhs <- c(rhs, paste("p_value", mod, sep = "*"))}
rhs <- paste(rhs, collapse = " + ")
f <- paste("o_value ~ ", rhs, collapse = "")
## compiled Bayesian model to speed up processing and avoid crashing
if(type == "Bayesian") load(sprintf("%s/results/1a_ipd_reg/bayes_sample_mod.RData", local_path))
## run the models & save
m <- if(type == "Frequentist"){lm_robust(formula(f), data = d, clusters = study, se_type = "CR0")} else {update(m, formula = f, newdata = d)}
save(m, file = sprintf("%s/results/1b_ipd_fixef/%s/models/%s_%s_%s_%s.RData"
, local_path, type, outcome, trait, mod, cov))
## extract model terms and confidence intervals & save
fx <- tidy(m, conf.int = T) %>%
select(term, estimate, conf.low, conf.high)
save(fx, file = sprintf("%s/results/1b_ipd_fixef/%s/summary/%s_%s_%s_%s.RData"
, local_path, type, outcome, trait, mod, cov))
## get simple effects for moderator tests
if(mod != "none"){
pred.fx <- ipd1b_simpeff_fun(m, mod, type, d)
save(pred.fx, file = sprintf("%s/results/1b_ipd_fixef/%s/predicted/%s_%s_%s_%s.RData", local_path, type, outcome, trait, mod, cov))
}
## clean up the local function environment
rm(list = c("d", "f", "rhs", "m", "fx"))
gc()
}3.2.2.3 Simple Effects Function
ipd1b_simpeff_fun <- function(m, moder, type, d){
d <- if(type == "Bayesian") m$data else d %>% select(o_value, one_of(rownames(attr(m$terms, "factors")))) %>% filter(complete.cases(.)) %>% data.frame()
d <- d %>% select(-o_value, -p_value)
cols <- colnames(d)
md_cl <- class(d[,moder])
if(any(sapply(d, class) == "numeric")){
msd <- d %>%
select_if(is.numeric) %>%
pivot_longer(everything()
, names_to = "item"
, values_to = "value") %>%
group_by(item) %>%
summarize_at(vars(value), lst(mean, sd), na.rm = T) %>%
ungroup()
}
if(any(sapply(d, class) == "factor")){
fct_lev <- d %>%
select_if(is.factor) %>%
summarize_all(~list(unique(.)))
}
d <- d %>% select(-one_of(moder))
md_levs <- if(md_cl == "numeric"){
if(moder %in% c("age", "baseAge", "baseYear")) {
c(-10, 0, 10)
} else if (moder %in% c("predInt", "education")) {
c(-5, 0, 5)
} else {
with(msd, c(mean[item == moder] - sd[item == moder], mean[item == moder], mean[item == moder] + sd[item == moder]))
}
} else {
unique(fct_lev[,moder][[1]])
}
mod_frame <- crossing(
p_value = seq(0,10,.5)
, modvalue = md_levs
) %>% setNames(c("p_value", moder))
if(ncol(d) > 0){
if(any(sapply(d, class) == "numeric")){
mod_frame <- tibble(mod_frame, d %>% select_if(is.numeric) %>% summarize_all(mean))
}
if(any(sapply(d, class) == "factor")){
mod_frame <- tibble(mod_frame, d %>% select_if(is.factor) %>% summarize_all(~levels(.)[1]))
}
}
pred.fx <- if(type == "Bayesian"){
bind_cols(
mod_frame,
fitted(m, newdata = mod_frame) %>% data.frame
) %>%
select(one_of(colnames(m$data)), pred = Estimate, lower = Q2.5, upper = Q97.5)
} else {
bind_cols(
mod_frame,
predict(m, newdata = mod_frame, interval = "confidence")$fit %>% data.frame
) %>%
select(one_of(rownames(attr(m$terms, "factors"))), pred = fit, lower = lwr, upper = upr)
}
rm(list = c("m", "mod_frame", "d", "md_levs"))
gc()
return(pred.fx)
}3.2.2.4 Run Models and Summaries
The code below generates all possible preregistrered combinations of traits, outcomes, types, moderators, and covariates. Then these combinations are fed serially to the model function written previously, which will run and save the results.
plan(multisession(workers = 12L))
nested_ipd1b_fixef <-
# moderator combinations
crossing(
Trait = traits$short_name
, Outcome = outcomes$short_name
, type = c("Frequentist")
, Moderator = c("age", "gender", "education")
, Covariate = c("none", "all")
) %>%
full_join(
# unmoderated combinations
crossing(
Trait = traits$short_name
, Outcome = outcomes$short_name
, type = c("Frequentist")
, Moderator = c("none")
, Covariate = c("none", "age", "gender", "education", "all")
)
) %>%
# filter(Trait == "N") %>%
mutate(run = future_pmap(
list(Trait, Outcome, type, Moderator, Covariate)
, ipd1b_mod_fun
, .progress = T
, .options = furrr_options(
globals = c("res_path", "local_path", "ipd1b_simpeff_fun", "traits", "studies", "outcomes", "covars", "moders")
, packages = c("plyr", "tidyverse", "broom.mixed", "broom", "estimatr")
)
))
closeAllConnections()
# nested_ipd1b_fixef %>%
# # select(-done) %>%
# write.table(.
# , file = sprintf("%s/scripts/cluster/args/frequentist/ipd1b_frequentist.txt", local_path)
# , row.names = F)3.2.2.5 Compile Results
Once all the models are run, we are ready to compile all their results. By saving the fixed effects results previously, we are able to simply load those results and ignore the models. However, because we also saved the models, we can also recall and extract information from them if and when needed.
loadRData <- function(fileName, type, obj, folder){
#loads an RData file, and returns it
path <- sprintf("%s/results/1b_ipd_fixef/%s/%s/%s", local_path, type, folder, fileName)
load(path)
get(ls()[grepl(obj, ls())])
}
## load in "fixed" effects
## first get file names
nested_ipd1b_fixef <- tibble(type = c("Frequentist", "Bayesian")) %>%
mutate(file = map(type, ~list.files(sprintf("%s/results/1b_ipd_fixef/%s/summary", local_path, .)))) %>%
unnest(file) %>%
separate(file, c("Outcome", "Trait", "Moderator", "Covariate"), sep = "_", remove = F) %>%
## read in the files
mutate(Covariate = str_remove(Covariate, ".RData"),
fx = map2(file, type, ~loadRData(.x, .y, "fx", "summary"))) %>%
select(-file) 3.2.2.5.1 Tables
Next, we want to format the study results in APA table format. In this case, we are interested in the fixed effects of personality predicting cognitive ability when there were no moderators, and the personality x moderator interaction when there was a moderator.
3.2.2.5.1.1 Fixed Effects
## format results
ipd1b_fixef_tab <- nested_ipd1b_fixef %>%
unnest(fx) %>%
filter((Moderator == "none" & term == "p_value") |
(Moderator != "none" & grepl("p_value:", term))) %>%
mutate(sig = ifelse(sign(conf.low) == sign(conf.high), "sig", "ns"),
Trait = factor(Trait, traits$short_name),
Outcome = factor(Outcome, outcomes$short_name, outcomes$long_name),
Moderator = factor(Moderator, c(moders$short_name, stdyModers$short_name), c(moders$long_name, stdyModers$long_name)),
Covariate = ifelse(Moderator != "None" & Covariate == "None", Moderator, Covariate),
Covariate = factor(Covariate, moders$short_name, str_wrap(moders$long_name, 15)),
term = str_remove_all(term, "p_value:"),
term = mapvalues(term, c("scaleBFIMS", "scaleIPIPNEO", "scaleTDAM40", "countryTheNetherlands")
, c("scaleBFI-S", "scaleIPIP NEO", "scaleTDA-40", "countryThe Netherlands")),
term2 = factor(term, c(moders$short_term, stdyModers$short_term),
c(moders$long_term, stdyModers$long_term))) %>%
mutate_at(vars(estimate, conf.low, conf.high),
~ifelse(abs(.) < .001, sprintf("%.3f", .), sprintf("%.2f", .))) %>%
mutate(est = sprintf("%s<br>[%s, %s]", estimate, conf.low, conf.high),
est = ifelse(sig == "sig", sprintf("<strong>%s</strong>", est), est)) %>%
# mutate(est = sprintf("%s [%s, %s]", estimate, conf.low, conf.high),
# est = ifelse(sig == "sig", sprintf("\\textbf{%s}", est), est)) %>%
select(-estimate, -conf.low, -conf.high, -sig, -term) %>%
arrange(type, Outcome, Trait, Moderator, Covariate) %>%
pivot_wider(names_from = "Trait", values_from = "est")
ipd1b_fixef_tab## # A tibble: 98 × 10
## type Outcome Moderator Covariate term2 E A C N O
## <chr> <fct> <fct> <fct> <fct> <chr> <chr> <chr> <chr> <chr>
## 1 Bayesian Crystallized Ability None None Personality <strong>-0.05<br>[-… <str… <str… <str… <str…
## 2 Bayesian Crystallized Ability None Age Personality <strong>-0.05<br>[-… <str… <str… <str… <str…
## 3 Bayesian Crystallized Ability None Gender Personality <strong>-0.06<br>[-… <str… <str… <str… <str…
## 4 Bayesian Crystallized Ability None Education Personality <strong>-0.06<br>[-… -0.0… <str… <str… <str…
## 5 Bayesian Crystallized Ability None Fully Adjusted Personality <strong>-0.08<br>[-… <str… 0.01… <str… <str…
## 6 Bayesian Crystallized Ability Age None Age <strong>-0.00<br>[-… <str… -0.0… <str… <str…
## 7 Bayesian Crystallized Ability Age Fully Adjusted Age <strong>-0.00<br>[-… <str… -0.0… <str… <str…
## 8 Bayesian Crystallized Ability Gender None Gender (Male v Female) <strong>0.09<br>[0.… 0.03… -0.0… -0.0… -0.0…
## 9 Bayesian Crystallized Ability Gender Fully Adjusted Gender (Male v Female) <strong>0.09<br>[0.… 0.03… 0.00… -0.0… -0.0…
## 10 Bayesian Crystallized Ability Education None Education (Years) -0.001<br>[-0.01, 0… <str… <str… <str… -0.0…
## # ℹ 88 more rowsipd1b_res <- nested_ipd1b_fixef %>%
unnest(fx) %>%
# keep key terms
filter((Moderator == "none" & term == "p_value") |
(Moderator != "none" & grepl("p_value:", term))) %>%
mutate(sig = ifelse(sign(conf.low) == sign(conf.high), "sig", "ns")) %>%
mutate_at(vars(estimate, conf.low, conf.high),
~ifelse(abs(.) < .01, sprintf("%.3f", .), sprintf("%.2f", .))) %>%
mutate(est = sprintf("\\textit{b} = %s, 95\\%% CI [%s, %s]", estimate, conf.low, conf.high)) Now that we’ve formatted the values, we can group by moderators and save results as separate tables. Even though additional information could be included given that we have one outcome, we’ll stick with this split because it will make it easier for those using this tutorial who multiple traits, outcomes, covariates, and moderators.
## table function
ipd1b_tab_fun <- function(d, type, moder){
# long outcome name
md <- mapvalues(moder, c("None", moders$long_name, stdyModers$long_name), c("none", moders$short_name, stdyModers$short_name), warn_missing = F)
d <- d %>% arrange(Outcome, Covariate, term2)
# getting row numbers for later grouping
rs <- d %>% group_by(Outcome) %>% tally() %>%
mutate(end = cumsum(n), start = lag(end) + 1, start = ifelse(is.na(start), 1, start))
cs <- if(length(unique(d$term2)) > 1) c(2, rep(1,5)) else rep(1,6)
names(cs) <- c(" ", paste0("<strong>", traits$long_name, "</strong>"))
# cln <- if(length(unique(d$term2)) == 1) c(" ", rep("\\textit{b} [CI]", 5)) else c(" ", "Term", rep("\\textit{b} [CI]", 5))
cln <- if(length(unique(d$term2)) == 1) c(" ", rep("<em>b</em> [CI]", 5)) else c(" ", "Term", rep("<em>b</em> [CI]", 5))
al <- if(length(unique(d$term2)) == 1) c("r", rep("c", 5)) else c("r", "r", rep("c", 5))
if(length(unique(d$term2)) == 1) {
d <- d %>% select(-term2); dubs <- F
}
cap <- if(md == "none") "1B Pooled Analysis of Individual Participant Data: Cluster Robust Fixed Effect Personality-Crystallized Domain Associations" else sprintf("1B Pooled Analysis of Individual Participant Data: Cluster Robust Fixed Effect %s Moderation of Personality-Crystallized Domain Associations", md)
tab <- d %>%
select(-Outcome) %>%
kable(., "html"
# kable(., "latex"
, booktabs = T
, escape = F
, col.names = cln
, align = al
, caption = cap
) %>%
kable_classic(full_width = F, html_font = "Times New Roman") %>%
# kable_styling(full_width = F, font_size = 7) %>%
collapse_rows(1, "top") %>%
add_header_above(cs, escape = F)
for (i in nrow(rs)){
tab <- tab %>%
kableExtra::group_rows(rs$Outcome[i], rs$start[i], rs$end[i])
}
save_kable(tab, file = sprintf("%s/results/1b_ipd_fixef/%s/tables/overall/%s.html"
, local_path, type, md))
return(tab)
}
ipd1b_fx_tab <- ipd1b_fixef_tab %>%
group_by(type, Moderator) %>%
nest() %>%
ungroup() %>%
mutate(tab = pmap(list(data, type, Moderator), ipd1b_tab_fun))
ipd1b_fx_tab## # A tibble: 14 × 4
## type Moderator data tab
## <chr> <fct> <list> <list>
## 1 Bayesian None <tibble [5 × 8]> <kablExtr [1]>
## 2 Bayesian Age <tibble [2 × 8]> <kablExtr [1]>
## 3 Bayesian Gender <tibble [2 × 8]> <kablExtr [1]>
## 4 Bayesian Education <tibble [2 × 8]> <kablExtr [1]>
## 5 Frequentist None <tibble [6 × 8]> <kablExtr [1]>
## 6 Frequentist Age <tibble [2 × 8]> <kablExtr [1]>
## 7 Frequentist Gender <tibble [2 × 8]> <kablExtr [1]>
## 8 Frequentist Education <tibble [2 × 8]> <kablExtr [1]>
## 9 Frequentist Continent <tibble [10 × 8]> <kablExtr [1]>
## 10 Frequentist Country <tibble [20 × 8]> <kablExtr [1]>
## 11 Frequentist Personality Scale <tibble [30 × 8]> <kablExtr [1]>
## 12 Frequentist Baseline Age <tibble [5 × 8]> <kablExtr [1]>
## 13 Frequentist Baseline Year <tibble [5 × 8]> <kablExtr [1]>
## 14 Frequentist Prediction Interval <tibble [5 × 8]> <kablExtr [1]># save(ipd1b_fixef_tab, ipd1b_res, file = sprintf("%s/manuscript/results/ipd1b_fx_tab.RData", local_path))
## Frequentist
(ipd1b_fx_tab %>% filter(type == "Frequentist" & Moderator == "None"))$tab[[1]]|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| b [CI] | b [CI] | b [CI] | b [CI] | b [CI] | |
| Crystallized Ability | |||||
| None |
-0.08 [-0.27, 0.10] |
-0.14 [-0.36, 0.08] |
0.01 [-0.17, 0.18] |
-0.00 [-0.15, 0.14] |
0.20 [0.06, 0.34] |
| Age |
-0.09 [-0.28, 0.11] |
-0.14 [-0.38, 0.10] |
0.01 [-0.17, 0.19] |
0.00 [-0.15, 0.15] |
0.19 [0.04, 0.34] |
| Gender |
-0.08 [-0.26, 0.11] |
-0.14 [-0.37, 0.10] |
0.02 [-0.16, 0.19] |
0.01 [-0.14, 0.16] |
0.19 [0.06, 0.32] |
| Self-Rated Physical Health |
0.01 [-0.35, 0.36] |
||||
| Education |
-0.07 [-0.22, 0.08] |
-0.06 [-0.23, 0.10] |
-0.01 [-0.15, 0.13] |
-0.03 [-0.13, 0.08] |
0.10 [-0.03, 0.24] |
|
-0.07 [-0.22, 0.08] |
-0.07 [-0.23, 0.08] |
-0.01 [-0.14, 0.12] |
-0.03 [-0.13, 0.08] |
0.11 [-0.03, 0.25] |
|
|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| b [CI] | b [CI] | b [CI] | b [CI] | b [CI] | |
| Crystallized Ability | |||||
| None |
-0.05 [-0.07, -0.04] |
-0.03 [-0.05, -0.01] |
0.04 [0.02, 0.06] |
0.11 [0.10, 0.13] |
0.16 [0.14, 0.18] |
|
-0.05 [-0.07, -0.04] |
-0.03 [-0.05, -0.01] |
0.04 [0.02, 0.06] |
0.11 [0.10, 0.13] |
0.16 [0.14, 0.18] |
|
| Gender |
-0.06 [-0.07, -0.04] |
-0.03 [-0.05, -0.01] |
0.04 [0.02, 0.06] |
0.12 [0.10, 0.13] |
0.16 [0.14, 0.18] |
| Education |
-0.06 [-0.08, -0.05] |
-0.02 [-0.04, 0.000] |
0.02 [0.00, 0.03] |
0.07 [0.06, 0.08] |
0.08 [0.06, 0.10] |
| Fully Adjusted |
-0.08 [-0.10, -0.07] |
-0.05 [-0.07, -0.03] |
0.01 [-0.01, 0.03] |
0.15 [0.13, 0.16] |
0.14 [0.13, 0.16] |
ipd1b_tab_fun <- function(d, type, cov){
# long outcome name
covar <- mapvalues(cov, covars$long_name, covars$short_name, warn_missing = F)
# getting row numbers for later grouping
rs <- d %>% group_by(Moderator) %>% tally() %>%
mutate(end = cumsum(n), start = lag(end) + 1, start = ifelse(is.na(start), 1, start))
# number and name of columns for span columns
cs <- rep(1,6)
names(cs) <- c(" ", traits$long_name)
# cln <- if(length(unique(d$term2)) == 1) c("Covariate", rep("\\textit{b} [CI]", 5)) else c(" ", "Term", rep("\\textit{b} [CI]", 5))
cln <- c("Term", rep("<em>b</em> [CI]", 5))
al <- c("r", rep("c", 5))
# caption
cv <- if (cov == "None") "Unadjusted" else cov
cap <- sprintf("1B Pooled Analysis of Individual Participant Data with Cluster Corrected Standard Errors: Fixed Effect Estimates of %s Personality-Crystallized Domain Associations", cv)
# kable the table
tab <- d %>%
select(-Moderator) %>%
kable(., "html"
# kable(., "latex"
, booktabs = T
, escape = F
, col.names = cln
, align = al
, caption = cap
) %>%
kable_classic(full_width = F, html_font = "Times New Roman") %>%
# kable_styling(full_width = F, font_size = 7) %>%
add_header_above(cs)
# for loop to add grouped sections
for (i in 1:nrow(rs)){
tab <- tab %>%
kableExtra::group_rows(rs$Moderator[i], rs$start[i], rs$end[i])
}
# save the resulting html table
save_kable(tab, file = sprintf("%s/results/1b_ipd_fixef/%s/tables/key terms/%s.html"
, local_path, type, covar))
return(tab) # return the html table
}
ipd1b_fx_tab2 <- ipd1b_fixef_tab %>%
filter(!Moderator %in% stdyModers$long_name) %>%
arrange(Moderator, term2) %>%
filter(Covariate %in% c("None", "Fully Adjusted")) %>%
group_by(Outcome, type, Covariate) %>%
nest() %>%
ungroup() %>%
mutate(tab = pmap(list(data, type, Covariate), ipd1b_tab_fun))
## Frequentist, no moderator
(ipd1b_fx_tab2 %>% filter(type == "Frequentist" & Covariate == "Fully Adjusted"))$tab[[1]]|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| Term | b [CI] | b [CI] | b [CI] | b [CI] | b [CI] |
| None | |||||
| Personality |
-0.07 [-0.22, 0.08] |
-0.07 [-0.23, 0.08] |
-0.01 [-0.14, 0.12] |
-0.03 [-0.13, 0.08] |
0.11 [-0.03, 0.25] |
| Age | |||||
| Age |
0.000 [-0.00, 0.00] |
-0.000 [-0.00, 0.00] |
-0.001 [-0.00, 0.00] |
0.00 [-0.00, 0.00] |
-0.00 [-0.01, 0.001] |
| Gender | |||||
| Gender (Male v Female) |
0.05 [0.001, 0.10] |
0.04 [-0.00, 0.08] |
0.03 [-0.07, 0.13] |
-0.01 [-0.08, 0.05] |
-0.02 [-0.08, 0.04] |
| Education | |||||
| Education (Years) |
0.00 [-0.01, 0.02] |
-0.00 [-0.03, 0.02] |
-0.01 [-0.03, 0.02] |
-0.00 [-0.02, 0.01] |
0.00 [-0.01, 0.01] |
|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| Term | b [CI] | b [CI] | b [CI] | b [CI] | b [CI] |
| None | |||||
| Personality |
-0.08 [-0.10, -0.07] |
-0.05 [-0.07, -0.03] |
0.01 [-0.01, 0.03] |
0.15 [0.13, 0.16] |
0.14 [0.13, 0.16] |
| Age | |||||
| Age |
-0.00 [-0.00, -0.000] |
-0.00 [-0.00, -0.000] |
-0.000 [-0.00, 0.00] |
0.00 [0.00, 0.00] |
-0.00 [-0.00, -0.000] |
| Gender | |||||
| Gender (Male v Female) |
0.09 [0.05, 0.12] |
0.03 [-0.01, 0.08] |
0.000 [-0.04, 0.04] |
-0.02 [-0.04, 0.01] |
-0.03 [-0.07, 0.00] |
| Education | |||||
| Education (Years) |
-0.01 [-0.01, -0.000] |
-0.02 [-0.03, -0.01] |
-0.02 [-0.02, -0.01] |
0.01 [0.01, 0.01] |
-0.00 [-0.01, 0.00] |
3.2.2.5.1.2 Study-Specific Effects
This header is here to simply emphasize that this method does not provide study-specific estimates, unlike Methods 2ab, 3, and 4.
3.2.2.5.1.3 Heterogeneity Estimates
This header is here to simply emphasize that this method does not provide heterogeneity estimates because it does not provide study-specific estimates, unlike Methods 2ab, 3, and 4.
3.2.2.5.1.4 All Model Terms
ipd1b_mod_tab <- nested_ipd1b_fixef %>%
unnest(fx) %>%
# keep key terms
# mark significance and prettify trait, outcome, and covariate names
mutate(sig = ifelse(sign(conf.low) == sign(conf.high), "sig", "ns"),
Trait = factor(Trait, traits$short_name),
Outcome = factor(Outcome, outcomes$short_name, outcomes$long_name),
Moderator = factor(Moderator, c(moders$short_name, stdyModers$short_name), c(moders$long_name, stdyModers$long_name)),
Covariate = factor(Covariate, covars$short_name, str_wrap(covars$long_name, 15))) %>%
# format values as text, combine estimates and CI's, bold significance
mutate_at(vars(estimate, conf.low, conf.high),
~ifelse(abs(.) < .01, sprintf("%.3f", .), sprintf("%.2f", .))) %>%
mutate(est = sprintf("%s<br>[%s, %s]", estimate, conf.low, conf.high),
est = ifelse(sig == "sig", sprintf("<strong>%s</strong>", est), est)) %>%
# mutate(est = sprintf("%s [%s, %s]", estimate, conf.low, conf.high),
# est = ifelse(sig == "sig", sprintf("\\textbf{%s}", est), est)) %>%
# final reshaping, remove extra columns, arrange values, and change to wide format
select(-estimate, -conf.low, -conf.high, -sig) %>%
arrange(type, Outcome, Trait, Moderator, Covariate) %>%
pivot_wider(names_from = "Trait", values_from = "est")
ipd1a_mod_tab_fun <- function(d, type, out, moder, cov){
md <- mapvalues(moder, c(moders$long_name, stdyModers$long_name), c(moders$short_name, stdyModers$short_name), warn_missing = F)
o <- mapvalues(out, outcomes$long_name, outcomes$short_name, warn_missing = F)
cv <- mapvalues(cov, covars$long_name, covars$short_name, warn_missing = F)
cs <- rep(1,6)
names(cs) <- c(" ", paste0("<strong>", traits$long_name, "</strong>"))
# cln <- if(length(unique(d$term2)) == 1) c("Covariate", rep("\\textit{b} [CI]", 5)) else c(" ", "Term", rep("\\textit{b} [CI]", 5))
cln <- c("Term", rep("<em>b</em> [CI]", 5))
al <- c("r", rep("c", 5))
# caption
cap <- if(md == "none") "1B Pooled Analysis of Individual Participant Data with Cluster Corrected Standard Errors: All Model Estimates of Fixed Effect Personality-Crystallized Domain Associations" else sprintf("1B Pooled Analysis of Individual Participant Data with Cluster Corrected Standard Errors: All Model Estimates of Fixed Effect %s Moderation of Personality-Crystallized Domain Associations", md)
# kable the table
tab <- d %>%
arrange(term) %>%
kable(., "html"
# kable(., "latex"
, booktabs = T
, escape = F
, col.names = cln
, align = al
, caption = cap
) %>%
kable_classic(full_width = F, html_font = "Times New Roman") %>%
# kable_styling(full_width = F, font_size = 7) %>%
add_header_above(cs, escape = F)
# save the resulting html table
save_kable(tab, file = sprintf("%s/results/1b_ipd_fixef/%s/tables/all terms/%s-%s-%s.html"
, local_path, type, o, md, cv))
return(tab) # return the html table
}
ipd1b_mod_tab <- ipd1b_mod_tab %>%
group_by(type, Outcome, Moderator, Covariate) %>%
nest() %>%
ungroup() %>%
mutate(tab = pmap(list(data, type, Outcome, Moderator, Covariate), ipd1a_mod_tab_fun))3.2.2.5.2 Figures
3.2.2.5.2.1 Overall Forest
ipd1b_fx_plot_fun <- function(df, mod, type, cov){
m <- mapvalues(mod, c(moders$short_name, stdyModers$short_name), c(moders$long_name, stdyModers$long_name), warn_missing = F)
cv <- mapvalues(cov, covars$short_name, covars$long_name, warn_missing = F)
d <- round(max(abs(min(df$estimate)), abs(max(df$estimate))), 3)
# stds <- unique(df$study)
lim <- c(0-d-(d/2.5), 0+d+(d/2.5))
brk <- if(d > .01) round(c(0-d-(d/5), 0, 0+d+(d/5)),2) else round(c(0-d-(d/5), 0, 0+d+(d/5)),3)
# lim_high <- lim[2]*4
lab <- str_replace(brk, "^0.", ".")#str_remove(round(c(0-d-(d/5), 0, 0+d+(d/5)),2), "^0")
shapes <- c(15, 16, 17, 18)[1:length(unique(df$term))]
lt <- rep("solid", length(unique(df$term)))
titl <- if(mod == "none"){NULL} else {sprintf("%s Moderation of Personality-Outcome Associations", m)}
titl <- if(!cov %in% c("none", "all")) paste(cv, "Adjusted", titl, collapse = " ") else paste(cv, titl, collapse = " ")
leg <- if(length(unique(df$term)) > 1){"bottom"} else {"none"}
p <- df %>%
mutate(conf.low = ifelse(conf.low < lim[1], lim[1], conf.low),
conf.high = ifelse(conf.high > lim[2], lim[2], conf.high)) %>%
ggplot(aes(x = Outcome, y = estimate)) +
scale_y_continuous(limits = lim, breaks = brk, labels = lab) +
scale_size_manual(values = c(1.4, 1.8)) +
scale_shape_manual(values = shapes) +
scale_color_manual(values = c("black", "blue")) +
scale_linetype_manual(values = lt) +
geom_hline(aes(yintercept = 0), size = .25, color = "gray50") +
geom_errorbar(aes(ymin = conf.low, ymax = conf.high, linetype = term)
, width = 0
, position = position_dodge(width = .9)) +
geom_point(aes(color = sig, size = sig, shape = term)
, position = position_dodge(width = .9)) +
labs(x = NULL
, y = "Estimate (POMP)"
, title = titl
, subtitle = "Method 1B: Pooled Linear Regression with Cluster-Corrected Standard Errors"
) +
guides(color = "none", size = "none") +
facet_grid(~Trait, scales = "free_y", space = "free") +
coord_flip() +
theme_classic() +
theme(legend.position = leg,
plot.title = element_text(face = "bold", size = rel(1.2), hjust = .5),
plot.subtitle = element_text(hjust = .5),
panel.background = element_rect(color = "black", fill = "white"),
strip.background = element_blank(),
strip.text = element_text(face = "bold", color = "black", size = rel(1.4)),
axis.text = element_text(color = "black"),
axis.text.y = element_text(size = rel(1)))
ht <- length(unique(df$Outcome)); ht2 <- length(unique(df$term))
wdt <- length(unique(df$Trait))
ggsave(file = sprintf("%s/results/1b_ipd_fixef/%s/figures/overall forest/%s_%s_fixed.png", local_path, type, mod, cov), width = wdt*2, height = ht+ht2)
rm(p)
gc()
return(T)
}
nested_ipd1b_fixef %>%
unnest(fx) %>%
filter((Moderator == "none" & term == "p_value")|
(Moderator != "none" & grepl("p_value:", term))) %>%
mutate(sig = ifelse(sign(conf.low) == sign(conf.high), "sig", "ns"),
sig = factor(sig, levels = c("sig","ns")),
Trait = factor(Trait, levels = traits$short_name),
Outcome = factor(Outcome, levels = outcomes$short_name, labels = str_wrap(outcomes$long_name, 15)),
Outcome = forcats::fct_rev(Outcome)) %>%
group_by(type, Moderator, Covariate) %>%
nest() %>%
ungroup() %>%
mutate(pmap(list(data, Moderator, type, Covariate), ipd1b_fx_plot_fun))3.2.2.5.2.2 Study-Specific Forest Plots
This header is here to simply emphasize that this method does not provide study-specific estimates, unlike Methods 2ab, 3, and 4.
3.2.2.5.2.3 Overall Simple Effects Plots
loadRData <- function(fileName, type, obj, folder){
#loads an RData file, and returns it
path <- sprintf("%s/results/1b_ipd_fixef/%s/%s/%s", local_path, type, folder, fileName)
load(path)
get(ls()[grepl(obj, ls())])
}
## load in "fixed" effects
## first get file names
nested_ipd1b_simp <- tibble(type = c("Frequentist", "Bayesian")) %>%
mutate(file = map(type, ~list.files(sprintf("%s/results/1b_ipd_fixef/%s/predicted", local_path, .)))) %>%
unnest(file) %>%
separate(file, c("Outcome", "Trait", "Moderator", "Covariate"), sep = "_", remove = F) %>%
## read in the files
mutate(Covariate = str_remove(Covariate, ".RData"),
pred = map2(file, type, ~loadRData(.x, .y, "pred.fx", "predicted"))) %>%
select(-file)
nested_ipd1a_simpsimp_eff_fun <- function(df, outcome, mod, type, cov){
print(paste(outcome, mod))
o <- mapvalues(outcome, outcomes$short_name, outcomes$long_name, warn_missing = F)
cv <- mapvalues(cov, covars$short_name, covars$long_name, warn_missing = F)
m <- mapvalues(mod, moders$short_name, moders$long_name, warn_missing = F)
d <- round(max(abs(min(df$pred)), abs(max(df$pred))), 3)
mini <- if(d > 2) .05 else 0-(d+(d/5))
maxi <- if(d > 2) 2.05 else 0+d+(d/5)
lim <- c(mini, maxi)
brk <- if(d > 2) c(0, 1, 2) else{round(c(0-d-(d/10), 0, 0+d+(d/10)),2)}
lab <- if(d > 2){c("0", "1", "2")} else{str_remove(c(round(0-d-(d/10),2), 0, round(0+d+(d/10),2)), "^0")}
titl <- if(mod == "none"){o} else {sprintf("%s: Personality x %s Simple Effects", o, m)}
# colnames(df)[colnames(df) == mod] <- "mod_value"
df <- df %>% unclass %>% data.frame
df$mod_value <- df[,mod]
df <- df %>% select(-all_of(mod)) %>% as_tibble
if(class(df$mod_value) == "factor"){df <- df %>% mutate(mod_fac = factor(mod_value))}
else{df <- df %>%
group_by(Trait) %>%
mutate(mod_fac = factor(mod_value, levels = unique(mod_value), labels = c("-1 SD", "M", "+1 SD"))) %>%
ungroup()
}
lt <- c("dotted", "solid", "dashed", "dotdash", "longdash", "twodash")[1:length(unique(df$mod_fac))]
df %>%
mutate(Trait = factor(Trait, levels = traits$short_name, labels = traits$long_name),
lower = ifelse(lower < 4, 4, lower),
upper = ifelse(upper > 10, 10, upper)) %>%
ggplot(aes(x = p_value
, y = pred
, group = mod_fac)) +
scale_y_continuous(limits = c(4,10)
, breaks = c(4, 6, 8, 10)
, labels = c(4, 6, 8, 10)) +
scale_linetype_manual(values = lt) +
geom_ribbon(aes(ymin = lower
, ymax = upper
, fill = mod_fac)
, alpha = .25) +
geom_line(aes(linetype = mod_fac)) +
labs(x = "Personality (POMP)"
, y = paste(o, "(POMP)")
, title = titl
, linetype = m
, fill = m
, subtitle = "Method 1B: Pooled Linear Regression with Cluster-Corrected Standard Errors") +
facet_wrap(~Trait, nrow = 3) +
theme_classic() +
theme(legend.position = "bottom"
, plot.title = element_text(face = "bold", size = rel(1.2), hjust = .5)
, strip.background = element_rect(fill = "black")
, strip.text = element_text(face = "bold", color = "white")
, axis.text = element_text(color = "black"))
ggsave(file = sprintf("%s/results/1b_ipd_fixef/%s/figures/overall simple effects/%s_%s_%s.png", local_path, type, outcome, mod, cov), width = 6, height = 6)
}
ipd1b_se_plot <- nested_ipd1b_simp %>%
group_by(type, Outcome, Moderator, Covariate) %>%
nest() %>%
ungroup() %>%
mutate(data = map(data, ~(.) %>% unnest(pred)),
plot = pmap(list(data, Outcome, Moderator, type, Covariate), simp_eff_fun))3.2.2.6 Sample Results Section
We examined estimates of overall prospective associations between Big Five personality characteristics and crystallized abilities as well as participant-level moderators of those associations using fully pooled, one-stage regression models with cluster-corrected standard errors using individual participant data in 11 studies. This allowed us to correct for clustering of data within studies without estimating sample-specific estimates. Table S2 presents the estimates of the key terms from all unmoderated and participant and sample-level moderators estimates from fully adjusted models. Across the 20 participant-level personality-cognitive ability associations and moderators of those associations, none were significant, including unmoderated associations between personality and crystallized abilities.
|
Extraversion
|
Agreeableness
|
Conscientiousness
|
Neuroticism
|
Openness to Experience
|
|
|---|---|---|---|---|---|
| Term | b [CI] | b [CI] | b [CI] | b [CI] | b [CI] |
| None | |||||
| Personality |
-0.07 [-0.22, 0.08] |
-0.07 [-0.23, 0.08] |
-0.01 [-0.14, 0.12] |
-0.03 [-0.13, 0.08] |
0.11 [-0.03, 0.25] |
| Age | |||||
| Age |
0.000 [-0.00, 0.00] |
-0.000 [-0.00, 0.00] |
-0.001 [-0.00, 0.00] |
0.00 [-0.00, 0.00] |
-0.00 [-0.01, 0.001] |
| Gender | |||||
| Gender (Male v Female) |
0.05 [0.001, 0.10] |
0.04 [-0.00, 0.08] |
0.03 [-0.07, 0.13] |
-0.01 [-0.08, 0.05] |
-0.02 [-0.08, 0.04] |
| Education | |||||
| Education (Years) |
0.00 [-0.01, 0.02] |
-0.00 [-0.03, 0.02] |
-0.01 [-0.03, 0.02] |
-0.00 [-0.02, 0.01] |
0.00 [-0.01, 0.01] |
The simple effects plots shown in Figure S2 provide a visualization to help better understand the moderators. The figure displays the predicted crystallized ability levels at different levels of the Big Five for males and females. Gender moderated the relationship between extraversion and later crystallized abilities (b = 0.06, 95% CI [0.001, 0.12]). The overall association between personality traits and later crystallized ability was null for extraversion for men (b = -0.01, 95% CI [-0.06, 0.03]) but positive for women (b = 0.05, 95% CI [0.004, 0.09]), such that women who were higher in extraversion tended to score higher on crystallized domain tasks. All other simple effects are available in the online materials and in the web app.
Figure 3.2: Figure S2. Simple effects of the prospective association between Big Five personality characteristics (rows) and crystallized abilities across gender (male, female) using all methods of data synthesis (columns). The x-axis captures personality in percentage of maximum possible (POMP) units, the y-axis captures crystallized abilities in POMP, and different panels represent each of the Big Five characteristics. Different lines indicate the predicted levels of cognitive ability for males (dotted line) and females (solid line).