I ran a Principal Components Analysis (PCA) on the variables used to create the composite index score in the City of Austin’s equity indicators map for Travis County. The variables included in the analysis are:
uninsured_est
est_child_pov
disability_est
EAL_VALP_x100
med_inc_hh_est
persistent_poverty
est_underemp_perc
eviction_filing_rate
below_pov_est
Energy_Burden___income
limited_english_hh_est
est_no_internet_perc
est_65plus_ambulatory
less_than_highschool_est
low_physical_activity_est
hh_support_risk_score
Overall, I found that low_physical_activity_est and less_than_highschool_est are highly correlated using a correlation coefficient of 85%. Using a correlation coefficient of 80%, est_child_pov and below_pov_est are also highly correlated.
Data Prep
library(tidyverse)
── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr 1.1.4 ✔ readr 2.1.5
✔ forcats 1.0.1 ✔ stringr 1.5.2
✔ ggplot2 4.0.0 ✔ tibble 3.3.0
✔ lubridate 1.9.4 ✔ tidyr 1.3.1
✔ purrr 1.1.0
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag() masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
library(recipes)
Warning: package 'recipes' was built under R version 4.5.2
Attaching package: 'recipes'
The following object is masked from 'package:stringr':
fixed
The following object is masked from 'package:stats':
step
library(ggplot2)library(writexl)
df <- readr::read_csv("IndexLayer_0.csv")
Rows: 261 Columns: 41
── Column specification ────────────────────────────────────────────────────────
Delimiter: ","
dbl (41): OBJECTID, SOURCE_ID, uninsured_est, est_child_pov, disability_est,...
ℹ Use `spec()` to retrieve the full column specification for this data.
ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
vars <-c("uninsured_est","est_child_pov","disability_est","EAL_VALP_x100","med_inc_hh_est","persistent_poverty","est_underemp_perc","eviction_filing_rate","below_pov_est","Energy_Burden____income_","limited_english_hh_est","est_no_internet_perc","est_65plus_ambulatory","less_than_highschool_est","low_physical_activity_est","hh_support_risk_score")
Data Exploration
# correlation look (pairwise)corr_df <- df %>% dplyr::select(dplyr::all_of(vars)) %>%mutate(across(everything(), as.numeric)) %>%cor(use ="pairwise.complete.obs", method ="pearson") %>%# for each pair of variables, use all rows where both of those variables have non-missing valuesas.data.frame()corr_df
# adding a heatmap here for visualizationcorr_long <- corr_df %>%rownames_to_column("var1") %>%pivot_longer(-var1, names_to ="var2", values_to ="r")ggplot(corr_long, aes(var1, var2, fill = r)) +geom_tile() +scale_fill_gradient2(limits =c(-1, 1)) +coord_fixed() +labs(title ="Correlation heatmap (Pearson)", x =NULL, y =NULL) +theme_minimal() +theme(axis.text.x =element_text(angle =45, hjust =1))
Visually, I can already see two pairs with strong positive correlations:
below_pov_est and est_child_pov
low_physical_activity and less_than_highschool_est
The first pair having a strong relationship makes sense, though it’s interesting that low_physical_activity and less_than_highschool_est have a strong relationship.
It makes sense that there is a negative correlation between median income and most of the other variables.
EAL_VALP_x100 and est_underemp_perc have weaker correlations overall (they’re contributing more independent information).
Principal Components Analysis (PCA)
Now, let’s run a PCA!
### PCA #### pre-processing data before PCApca_recipe <-recipe(~ ., data = df %>% dplyr::select(dplyr::all_of(vars))) %>%# ensure numericstep_mutate(across(everything(), as.numeric)) %>%# impute missing values to avoid dropping rows (If a variable has missing values, replace those missing values with the median of that variable. PCA cannot run if there are missing values.)step_impute_median(all_numeric_predictors()) %>%# standardize (center/scale) — critical for PCA across different unitsstep_normalize(all_numeric_predictors())# learn parameters and apply to datapca_prep <-prep(pca_recipe)X <-bake(pca_prep, new_data =NULL) # matrix used for PCA# run PCA (on already standardized data)pca <-prcomp(X, center =FALSE, scale. =FALSE)pca
Let’s remove collinear predictors by correlation (caret). I used a cut off of 85%, but this can be changed.
library(caret)
Warning: package 'caret' was built under R version 4.5.2
Loading required package: lattice
Attaching package: 'caret'
The following object is masked from 'package:purrr':
lift
X <- df %>%select(all_of(vars)) %>%mutate(across(everything(), as.numeric))# pairwise Pearson correlations with pairwise NAscm <-cor(X, use ="pairwise.complete.obs", method ="pearson")# find variables to drop at a high-correlation cutoff (going with 85% for now)to_drop <-findCorrelation(cm, cutoff =0.85, names =TRUE, verbose =TRUE)
Compare row 15 and column 14 with corr 0.852
Means: 0.466 vs 0.276 so flagging column 15
All correlations <= 0.85
The above analysis found one pair over the cutoff (≥ 0.85): low_physical_activity_est (row 15) vs less_than_highschool_est (col 14) with r = 0.852. This aligns with the heat map I previously made.
Each variable’s mean absolute correlation was compared with all others: low_physical_activity_est had 0.466 vs. less_than_highschool_est 0.276.
Since low_physical_activity_est is more correlated on average with the rest, it’s the more redundant one, so caret drops it.
After dropping that one, all remaining pairs are ≤ 0.85, so nothing else is removed.
I was wondering why child poverty or overall poverty weren’t flagged, so I wanted to check:
cm["below_pov_est", "est_child_pov"]
[1] 0.8198475
As seen above, child poverty and poverty do not meet the 85% cutoff, as their r = 0.8198. Though, they are still pretty highly correlated.
Additional Info
Now, let’s visualize how much variance each Principal Component (PC) explains.
# scree plot (variance explained)eigs <- pca$sdev^2# eigenvalues (how much variance each PC holds)var_explained <- eigs /sum(eigs) # turn eigs into a % of total variancescree_df <-tibble(PC =paste0("PC", seq_along(eigs)),Eigenvalue = eigs,Variance = var_explained,CumVariance =cumsum(var_explained) # shows how much total variance is covered by first couple PCs)ggplot(scree_df, aes(x =seq_along(PC), y = Variance)) +geom_point() +geom_line() +scale_x_continuous(breaks =seq_along(scree_df$PC)) +labs(title ="Scree plot", x ="Principal Component", y ="Proportion of Variance") +theme_minimal()
The scree plot shows us that PC1 explains the largest chunk of variance (around 40%), while PC2 explains much less (around 10%). PC3 and onward each contribute only around 5% and then gradually go down.
This means that there is one dominant underlying dimension shared across all the variables. So, many of the variables are reflecting the same underlying construct.
This is was we’d expect with these types of sociodemographic variables, as we know they are all related when it comes to equity outcomes.
Next, let’s see which variables drive each PC.
# absolute loadings near |1| indicate variables move together strongly along that PCloadings <-as.data.frame(pca$rotation) %>%rownames_to_column("variable")# top contributors per PC n <-8# can change n to list more/lesstop_by_pc <-map_dfr(colnames(pca$rotation),~ loadings %>%select(variable, all_of(.x)) %>%arrange(desc(abs(.data[[.x]]))) %>%slice_head(n = n) %>%mutate(PC = .x),.id ="pc_order") %>%select(PC, variable, loading =starts_with("PC"))print(top_by_pc)
loading3 variable loading1 loading2 loading4
1 PC1 low_physical_activity_est 1 -0.3716986 NA
2 PC1 less_than_highschool_est 1 -0.3368083 NA
3 PC1 uninsured_est 1 -0.3243518 NA
4 PC1 Energy_Burden____income_ 1 -0.3128046 NA
5 PC1 below_pov_est 1 -0.3014254 NA
6 PC1 med_inc_hh_est 1 0.2939238 NA
7 PC1 limited_english_hh_est 1 -0.2828106 NA
8 PC1 est_no_internet_perc 1 -0.2792894 NA
9 PC2 est_underemp_perc 2 NA 0.5672625
10 PC2 persistent_poverty 2 NA 0.4504690
11 PC2 below_pov_est 2 NA 0.3940757
12 PC2 est_child_pov 2 NA 0.2968463
13 PC2 est_65plus_ambulatory 2 NA -0.2208444
14 PC2 eviction_filing_rate 2 NA -0.2055338
15 PC2 hh_support_risk_score 2 NA -0.1925660
16 PC2 EAL_VALP_x100 2 NA 0.1768411
17 PC3 EAL_VALP_x100 3 NA NA
18 PC3 est_65plus_ambulatory 3 NA NA
19 PC3 disability_est 3 NA NA
20 PC3 persistent_poverty 3 NA NA
21 PC3 limited_english_hh_est 3 NA NA
22 PC3 less_than_highschool_est 3 NA NA
23 PC3 uninsured_est 3 NA NA
24 PC3 Energy_Burden____income_ 3 NA NA
25 PC4 eviction_filing_rate 4 NA NA
26 PC4 disability_est 4 NA NA
27 PC4 EAL_VALP_x100 4 NA NA
28 PC4 est_no_internet_perc 4 NA NA
29 PC4 est_65plus_ambulatory 4 NA NA
30 PC4 limited_english_hh_est 4 NA NA
31 PC4 est_underemp_perc 4 NA NA
32 PC4 uninsured_est 4 NA NA
33 PC5 hh_support_risk_score 5 NA NA
34 PC5 EAL_VALP_x100 5 NA NA
35 PC5 persistent_poverty 5 NA NA
36 PC5 est_child_pov 5 NA NA
37 PC5 est_65plus_ambulatory 5 NA NA
38 PC5 below_pov_est 5 NA NA
39 PC5 est_no_internet_perc 5 NA NA
40 PC5 est_underemp_perc 5 NA NA
41 PC6 hh_support_risk_score 6 NA NA
42 PC6 persistent_poverty 6 NA NA
43 PC6 EAL_VALP_x100 6 NA NA
44 PC6 est_no_internet_perc 6 NA NA
45 PC6 med_inc_hh_est 6 NA NA
46 PC6 limited_english_hh_est 6 NA NA
47 PC6 est_child_pov 6 NA NA
48 PC6 below_pov_est 6 NA NA
49 PC7 est_child_pov 7 NA NA
50 PC7 EAL_VALP_x100 7 NA NA
51 PC7 eviction_filing_rate 7 NA NA
52 PC7 est_65plus_ambulatory 7 NA NA
53 PC7 est_underemp_perc 7 NA NA
54 PC7 est_no_internet_perc 7 NA NA
55 PC7 persistent_poverty 7 NA NA
56 PC7 below_pov_est 7 NA NA
57 PC8 est_underemp_perc 8 NA NA
58 PC8 eviction_filing_rate 8 NA NA
59 PC8 persistent_poverty 8 NA NA
60 PC8 est_65plus_ambulatory 8 NA NA
61 PC8 Energy_Burden____income_ 8 NA NA
62 PC8 med_inc_hh_est 8 NA NA
63 PC8 est_child_pov 8 NA NA
64 PC8 disability_est 8 NA NA
65 PC9 disability_est 9 NA NA
66 PC9 est_no_internet_perc 9 NA NA
67 PC9 med_inc_hh_est 9 NA NA
68 PC9 est_child_pov 9 NA NA
69 PC9 persistent_poverty 9 NA NA
70 PC9 est_65plus_ambulatory 9 NA NA
71 PC9 uninsured_est 9 NA NA
72 PC9 hh_support_risk_score 9 NA NA
73 PC10 med_inc_hh_est 10 NA NA
74 PC10 disability_est 10 NA NA
75 PC10 est_65plus_ambulatory 10 NA NA
76 PC10 less_than_highschool_est 10 NA NA
77 PC10 est_child_pov 10 NA NA
78 PC10 EAL_VALP_x100 10 NA NA
79 PC10 eviction_filing_rate 10 NA NA
80 PC10 low_physical_activity_est 10 NA NA
81 PC11 Energy_Burden____income_ 11 NA NA
82 PC11 limited_english_hh_est 11 NA NA
83 PC11 est_65plus_ambulatory 11 NA NA
84 PC11 low_physical_activity_est 11 NA NA
85 PC11 est_no_internet_perc 11 NA NA
86 PC11 est_underemp_perc 11 NA NA
87 PC11 less_than_highschool_est 11 NA NA
88 PC11 eviction_filing_rate 11 NA NA
89 PC12 limited_english_hh_est 12 NA NA
90 PC12 est_no_internet_perc 12 NA NA
91 PC12 uninsured_est 12 NA NA
92 PC12 persistent_poverty 12 NA NA
93 PC12 disability_est 12 NA NA
94 PC12 eviction_filing_rate 12 NA NA
95 PC12 est_underemp_perc 12 NA NA
96 PC12 med_inc_hh_est 12 NA NA
97 PC13 Energy_Burden____income_ 13 NA NA
98 PC13 uninsured_est 13 NA NA
99 PC13 est_no_internet_perc 13 NA NA
100 PC13 disability_est 13 NA NA
101 PC13 less_than_highschool_est 13 NA NA
102 PC13 low_physical_activity_est 13 NA NA
103 PC13 est_65plus_ambulatory 13 NA NA
104 PC13 est_underemp_perc 13 NA NA
105 PC14 uninsured_est 14 NA NA
106 PC14 less_than_highschool_est 14 NA NA
107 PC14 med_inc_hh_est 14 NA NA
108 PC14 low_physical_activity_est 14 NA NA
109 PC14 Energy_Burden____income_ 14 NA NA
110 PC14 disability_est 14 NA NA
111 PC14 eviction_filing_rate 14 NA NA
112 PC14 persistent_poverty 14 NA NA
113 PC15 below_pov_est 15 NA NA
114 PC15 est_child_pov 15 NA NA
115 PC15 low_physical_activity_est 15 NA NA
116 PC15 less_than_highschool_est 15 NA NA
117 PC15 med_inc_hh_est 15 NA NA
118 PC15 est_underemp_perc 15 NA NA
119 PC15 persistent_poverty 15 NA NA
120 PC15 Energy_Burden____income_ 15 NA NA
121 PC16 low_physical_activity_est 16 NA NA
122 PC16 less_than_highschool_est 16 NA NA
123 PC16 below_pov_est 16 NA NA
124 PC16 est_child_pov 16 NA NA
125 PC16 Energy_Burden____income_ 16 NA NA
126 PC16 est_no_internet_perc 16 NA NA
127 PC16 disability_est 16 NA NA
128 PC16 est_underemp_perc 16 NA NA
loading5 loading6 loading7 loading8 loading9 loading10
1 NA NA NA NA NA NA
2 NA NA NA NA NA NA
3 NA NA NA NA NA NA
4 NA NA NA NA NA NA
5 NA NA NA NA NA NA
6 NA NA NA NA NA NA
7 NA NA NA NA NA NA
8 NA NA NA NA NA NA
9 NA NA NA NA NA NA
10 NA NA NA NA NA NA
11 NA NA NA NA NA NA
12 NA NA NA NA NA NA
13 NA NA NA NA NA NA
14 NA NA NA NA NA NA
15 NA NA NA NA NA NA
16 NA NA NA NA NA NA
17 0.5720965 NA NA NA NA NA
18 -0.4410464 NA NA NA NA NA
19 -0.3991605 NA NA NA NA NA
20 -0.3017962 NA NA NA NA NA
21 0.2909768 NA NA NA NA NA
22 0.1591099 NA NA NA NA NA
23 0.1474920 NA NA NA NA NA
24 0.1457073 NA NA NA NA NA
25 NA 0.6331530 NA NA NA NA
26 NA 0.3735869 NA NA NA NA
27 NA 0.3301717 NA NA NA NA
28 NA -0.3067518 NA NA NA NA
29 NA 0.2597827 NA NA NA NA
30 NA -0.2254813 NA NA NA NA
31 NA 0.2143052 NA NA NA NA
32 NA -0.2002304 NA NA NA NA
33 NA NA 0.6317769 NA NA NA
34 NA NA -0.3913639 NA NA NA
35 NA NA -0.3319689 NA NA NA
36 NA NA 0.2852734 NA NA NA
37 NA NA -0.2835290 NA NA NA
38 NA NA 0.1970508 NA NA NA
39 NA NA -0.1776511 NA NA NA
40 NA NA 0.1677476 NA NA NA
41 NA NA NA 0.6881147 NA NA
42 NA NA NA 0.4186006 NA NA
43 NA NA NA 0.3972334 NA NA
44 NA NA NA 0.2466550 NA NA
45 NA NA NA 0.2353944 NA NA
46 NA NA NA -0.1457711 NA NA
47 NA NA NA -0.1391771 NA NA
48 NA NA NA -0.1049132 NA NA
49 NA NA NA NA -0.3980232 NA
50 NA NA NA NA -0.3772934 NA
51 NA NA NA NA 0.3580261 NA
52 NA NA NA NA -0.3574175 NA
53 NA NA NA NA 0.3316537 NA
54 NA NA NA NA 0.2795170 NA
55 NA NA NA NA 0.2677165 NA
56 NA NA NA NA -0.2420589 NA
57 NA NA NA NA NA -0.5505328
58 NA NA NA NA NA 0.4808853
59 NA NA NA NA NA 0.3675718
60 NA NA NA NA NA -0.2972368
61 NA NA NA NA NA -0.2774428
62 NA NA NA NA NA -0.2055165
63 NA NA NA NA NA 0.2034605
64 NA NA NA NA NA -0.1836731
65 NA NA NA NA NA NA
66 NA NA NA NA NA NA
67 NA NA NA NA NA NA
68 NA NA NA NA NA NA
69 NA NA NA NA NA NA
70 NA NA NA NA NA NA
71 NA NA NA NA NA NA
72 NA NA NA NA NA NA
73 NA NA NA NA NA NA
74 NA NA NA NA NA NA
75 NA NA NA NA NA NA
76 NA NA NA NA NA NA
77 NA NA NA NA NA NA
78 NA NA NA NA NA NA
79 NA NA NA NA NA NA
80 NA NA NA NA NA NA
81 NA NA NA NA NA NA
82 NA NA NA NA NA NA
83 NA NA NA NA NA NA
84 NA NA NA NA NA NA
85 NA NA NA NA NA NA
86 NA NA NA NA NA NA
87 NA NA NA NA NA NA
88 NA NA NA NA NA NA
89 NA NA NA NA NA NA
90 NA NA NA NA NA NA
91 NA NA NA NA NA NA
92 NA NA NA NA NA NA
93 NA NA NA NA NA NA
94 NA NA NA NA NA NA
95 NA NA NA NA NA NA
96 NA NA NA NA NA NA
97 NA NA NA NA NA NA
98 NA NA NA NA NA NA
99 NA NA NA NA NA NA
100 NA NA NA NA NA NA
101 NA NA NA NA NA NA
102 NA NA NA NA NA NA
103 NA NA NA NA NA NA
104 NA NA NA NA NA NA
105 NA NA NA NA NA NA
106 NA NA NA NA NA NA
107 NA NA NA NA NA NA
108 NA NA NA NA NA NA
109 NA NA NA NA NA NA
110 NA NA NA NA NA NA
111 NA NA NA NA NA NA
112 NA NA NA NA NA NA
113 NA NA NA NA NA NA
114 NA NA NA NA NA NA
115 NA NA NA NA NA NA
116 NA NA NA NA NA NA
117 NA NA NA NA NA NA
118 NA NA NA NA NA NA
119 NA NA NA NA NA NA
120 NA NA NA NA NA NA
121 NA NA NA NA NA NA
122 NA NA NA NA NA NA
123 NA NA NA NA NA NA
124 NA NA NA NA NA NA
125 NA NA NA NA NA NA
126 NA NA NA NA NA NA
127 NA NA NA NA NA NA
128 NA NA NA NA NA NA
loading11 loading12 loading13 loading14 loading15 loading16
1 NA NA NA NA NA NA
2 NA NA NA NA NA NA
3 NA NA NA NA NA NA
4 NA NA NA NA NA NA
5 NA NA NA NA NA NA
6 NA NA NA NA NA NA
7 NA NA NA NA NA NA
8 NA NA NA NA NA NA
9 NA NA NA NA NA NA
10 NA NA NA NA NA NA
11 NA NA NA NA NA NA
12 NA NA NA NA NA NA
13 NA NA NA NA NA NA
14 NA NA NA NA NA NA
15 NA NA NA NA NA NA
16 NA NA NA NA NA NA
17 NA NA NA NA NA NA
18 NA NA NA NA NA NA
19 NA NA NA NA NA NA
20 NA NA NA NA NA NA
21 NA NA NA NA NA NA
22 NA NA NA NA NA NA
23 NA NA NA NA NA NA
24 NA NA NA NA NA NA
25 NA NA NA NA NA NA
26 NA NA NA NA NA NA
27 NA NA NA NA NA NA
28 NA NA NA NA NA NA
29 NA NA NA NA NA NA
30 NA NA NA NA NA NA
31 NA NA NA NA NA NA
32 NA NA NA NA NA NA
33 NA NA NA NA NA NA
34 NA NA NA NA NA NA
35 NA NA NA NA NA NA
36 NA NA NA NA NA NA
37 NA NA NA NA NA NA
38 NA NA NA NA NA NA
39 NA NA NA NA NA NA
40 NA NA NA NA NA NA
41 NA NA NA NA NA NA
42 NA NA NA NA NA NA
43 NA NA NA NA NA NA
44 NA NA NA NA NA NA
45 NA NA NA NA NA NA
46 NA NA NA NA NA NA
47 NA NA NA NA NA NA
48 NA NA NA NA NA NA
49 NA NA NA NA NA NA
50 NA NA NA NA NA NA
51 NA NA NA NA NA NA
52 NA NA NA NA NA NA
53 NA NA NA NA NA NA
54 NA NA NA NA NA NA
55 NA NA NA NA NA NA
56 NA NA NA NA NA NA
57 NA NA NA NA NA NA
58 NA NA NA NA NA NA
59 NA NA NA NA NA NA
60 NA NA NA NA NA NA
61 NA NA NA NA NA NA
62 NA NA NA NA NA NA
63 NA NA NA NA NA NA
64 NA NA NA NA NA NA
65 -0.4401481 NA NA NA NA NA
66 -0.4279389 NA NA NA NA NA
67 -0.4069827 NA NA NA NA NA
68 -0.3591117 NA NA NA NA NA
69 0.2825587 NA NA NA NA NA
70 0.2775109 NA NA NA NA NA
71 0.2475081 NA NA NA NA NA
72 0.1756149 NA NA NA NA NA
73 NA 0.6125342 NA NA NA NA
74 NA -0.4294181 NA NA NA NA
75 NA 0.3776642 NA NA NA NA
76 NA 0.3230627 NA NA NA NA
77 NA 0.2224785 NA NA NA NA
78 NA -0.2175248 NA NA NA NA
79 NA 0.1962192 NA NA NA NA
80 NA 0.1864716 NA NA NA NA
81 NA NA 0.5622539 NA NA NA
82 NA NA -0.5574847 NA NA NA
83 NA NA -0.3170848 NA NA NA
84 NA NA 0.2658291 NA NA NA
85 NA NA -0.2298704 NA NA NA
86 NA NA -0.2284559 NA NA NA
87 NA NA 0.1574557 NA NA NA
88 NA NA -0.1550764 NA NA NA
89 NA NA NA -0.6123472 NA NA
90 NA NA NA 0.4878974 NA NA
91 NA NA NA 0.3175205 NA NA
92 NA NA NA -0.2678328 NA NA
93 NA NA NA -0.2380919 NA NA
94 NA NA NA 0.2054327 NA NA
95 NA NA NA 0.1916358 NA NA
96 NA NA NA -0.1909172 NA NA
97 NA NA NA NA -0.5787509 NA
98 NA NA NA NA 0.4170957 NA
99 NA NA NA NA -0.3887958 NA
100 NA NA NA NA 0.3386366 NA
101 NA NA NA NA 0.2913143 NA
102 NA NA NA NA 0.2037509 NA
103 NA NA NA NA -0.1849307 NA
104 NA NA NA NA 0.1757315 NA
105 NA NA NA NA NA -0.6544238
106 NA NA NA NA NA 0.4341611
107 NA NA NA NA NA -0.4049650
108 NA NA NA NA NA 0.3170131
109 NA NA NA NA NA -0.2084212
110 NA NA NA NA NA -0.1314154
111 NA NA NA NA NA -0.1176398
112 NA NA NA NA NA -0.1145323
113 NA NA NA NA NA NA
114 NA NA NA NA NA NA
115 NA NA NA NA NA NA
116 NA NA NA NA NA NA
117 NA NA NA NA NA NA
118 NA NA NA NA NA NA
119 NA NA NA NA NA NA
120 NA NA NA NA NA NA
121 NA NA NA NA NA NA
122 NA NA NA NA NA NA
123 NA NA NA NA NA NA
124 NA NA NA NA NA NA
125 NA NA NA NA NA NA
126 NA NA NA NA NA NA
127 NA NA NA NA NA NA
128 NA NA NA NA NA NA
loading17 loading18
1 NA NA
2 NA NA
3 NA NA
4 NA NA
5 NA NA
6 NA NA
7 NA NA
8 NA NA
9 NA NA
10 NA NA
11 NA NA
12 NA NA
13 NA NA
14 NA NA
15 NA NA
16 NA NA
17 NA NA
18 NA NA
19 NA NA
20 NA NA
21 NA NA
22 NA NA
23 NA NA
24 NA NA
25 NA NA
26 NA NA
27 NA NA
28 NA NA
29 NA NA
30 NA NA
31 NA NA
32 NA NA
33 NA NA
34 NA NA
35 NA NA
36 NA NA
37 NA NA
38 NA NA
39 NA NA
40 NA NA
41 NA NA
42 NA NA
43 NA NA
44 NA NA
45 NA NA
46 NA NA
47 NA NA
48 NA NA
49 NA NA
50 NA NA
51 NA NA
52 NA NA
53 NA NA
54 NA NA
55 NA NA
56 NA NA
57 NA NA
58 NA NA
59 NA NA
60 NA NA
61 NA NA
62 NA NA
63 NA NA
64 NA NA
65 NA NA
66 NA NA
67 NA NA
68 NA NA
69 NA NA
70 NA NA
71 NA NA
72 NA NA
73 NA NA
74 NA NA
75 NA NA
76 NA NA
77 NA NA
78 NA NA
79 NA NA
80 NA NA
81 NA NA
82 NA NA
83 NA NA
84 NA NA
85 NA NA
86 NA NA
87 NA NA
88 NA NA
89 NA NA
90 NA NA
91 NA NA
92 NA NA
93 NA NA
94 NA NA
95 NA NA
96 NA NA
97 NA NA
98 NA NA
99 NA NA
100 NA NA
101 NA NA
102 NA NA
103 NA NA
104 NA NA
105 NA NA
106 NA NA
107 NA NA
108 NA NA
109 NA NA
110 NA NA
111 NA NA
112 NA NA
113 0.63565250 NA
114 -0.56119357 NA
115 0.40003779 NA
116 -0.21507163 NA
117 0.19480713 NA
118 -0.12457965 NA
119 -0.11935154 NA
120 -0.06339945 NA
121 NA -0.65801523
122 NA 0.55761951
123 NA 0.42577756
124 NA -0.16922291
125 NA 0.10903908
126 NA -0.10320491
127 NA 0.09214728
128 NA -0.06300568
write_xlsx(top_by_pc, "top_by_pc_loadings.xlsx")
How much variance of each variable is explained by retained PCs:
# communalities# choose how many PCs to keep; common choices: Kaiser (eigenvalue > 1) or target cum var (e.g., 70–90%)k_kaiser <-sum(eigs >1)k_target <-which(scree_df$CumVariance >=0.80)[1] # 80% targetk <-max(k_kaiser, k_target, na.rm =TRUE) # take the more conservativecommunalities <- loadings %>%select(variable, starts_with("PC")) %>%mutate(comm =rowSums(across(all_of(paste0("PC", 1:k)), ~ .x^2))) %>%arrange(desc(comm))print(communalities)
# 1) If the first 1–2 PCs explain a large share of variance (e.g., > 60–70%),# your predictors share substantial common signal (i.e., multicollinearity).# 2) Variables with very high absolute loadings on the SAME PC tend to be redundant.# 3) High communalities (~0.7+) mean a variable is largely explained by the common factors (less unique info).cat("\n--- PCA quick summary ---\n")
cat(sprintf("Variance explained by first 5 PCs: %s\n", paste(round(100*var_explained[1:min(5, length(var_explained))], 1), collapse ="%, "), "%\n"))
Warning in sprintf("Variance explained by first 5 PCs: %s\n", paste(round(100 * : one argument not used by format 'Variance explained by first 5 PCs: %s
'
Variance explained by first 5 PCs: 37.6%, 10.1%, 7.6%, 6.4%, 6.1
