For the purposes of this question, assume we have 10-dimensional data - that is, ignore the Overall column.
A)
Explain why we need to scale this data set before performing PCA.
If not scaled, events that have higher scores will naturally have higher variance therefore carry more weight. Specifically, the 1500m race is the only one with scores in the triple digits, so that will have the most impact. The units are also different. So when I say ‘scores’ sometimes that means distance and sometimes that means time, which is a reason to scale the data.
B)
Use svd() to find the first 2 principal component scores and their loadings. Full credit will only be granted if you use the svd() ingredients u, d, and v. What percent of the overall variability do the first two PCs explain?
library(tidyverse)
── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr 1.2.1 ✔ readr 2.2.0
✔ forcats 1.0.1 ✔ stringr 1.6.0
✔ ggplot2 4.0.3 ✔ tibble 3.3.1
✔ lubridate 1.9.5 ✔ tidyr 1.3.2
✔ purrr 1.2.2
── 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
The first two PCs explain about 48.41% of the total variability (PC1: 29.13%, PC2: 19.28%).
C)
Find and print the loadings. Based on the loadings alone, if the first two PCs are plotted in a 2D plane as shown below, which of the four quadrants will the medalists be in? Explain your reasoning.
The medalists should be in Quadrant II (negative PC1 and positive PC2).
PC1: The biggest positive loadings are for the running events (100m, 400m, and 110m hurdles), while the long jump, shot put, high jump, and discus have negative loadings. Since lower times are better in running events, faster runners will have lower values, which pushes PC1 down. The same goes for athletes who do well in the jumping and throwing events. So overall, the better all-around athletes should have negative PC1 scores.
PC2: The biggest loadings are for discus (0.596), shot put (0.531), and pole vault (0.481). This means PC2 is mostly picking up performance in those events. Athletes who do well in these events should have higher PC2 scores. Medalists would likely have positive PC2 scores.
D)
Add the PCs to the decathlon data set and create a scatterplot of these PCs, with the points labeled by the athletes’ names. Color-code the points on whether or not the athlete was a medalist. Use the ggrepel package for better labeling. Verify that your intuition from C) is correct.
library(ggrepel)decathlon_pcs <- (decathlon%>%bind_cols(data.frame(PCs[, 1:2]))%>%rename(PC1 = X1, PC2 = X2)%>%mutate(Medalist =ifelse(Medal =='None','No', 'Yes')))ggplot(data = decathlon_pcs) +geom_hline(yintercept =0, color ='gray') +geom_vline(xintercept =0, color ='gray') +geom_point(aes(x = PC1, y = PC2, color = Medalist)) +geom_text_repel(aes(x = PC1, y = PC2,label = Athlete, color = Medalist),size =3, show.legend =FALSE) +scale_color_manual(values =c('No'='black','Yes'='orange')) +labs(x ='PC1', y ='PC2') +theme_classic(base_size =14)
Correct….medalists in Q2
E)
Canadian Damian Warner won the gold medal in the decathlon in the 2020 Tokyo games. He began the 2024 decathlon but bowed out after three straight missed pole vault attempts.
Would this have won a medal if it had happened in 2024? To answer this, we will compute his PCs with respect to the 2024 athletes and add it to the plot to see where his 2020 gold-medal performance compares to the 2024 athletes. To do this:
Find the mean vector from the 2024 athletes. Call it mean_vec_24.
Find the standard deviation vector from the 2024 athletes. Call it sd_vec_24.
Standardize Warner’s 2020 results with respect to the 2024 athletes: (warner-mean_vec_24)/sd_vec_24
Find Warner’s PC coordinates using the 2024 loadings.
Add his point to the scatterplot.
Do you think his 2020 performance would have won a medal if it had happened in 2024?
mean_vec_24 <- (decathlon%>%select(X100m:X1500m)%>%apply(2, mean))sd_vec_24 <- (decathlon%>%select(X100m:X1500m)%>%apply(2, sd))warner_scaled <- (warner - mean_vec_24)/sd_vec_24warner_pcs <- (warner_scaled %*% V[, 1:2]%>%data.frame()%>%rename(PC1 = X1, PC2 = X2)%>%mutate(Athlete ='Damian Warner (2020)'))warner_pcsggplot(data = decathlon_pcs) +geom_hline(yintercept =0, color ='gray') +geom_vline(xintercept =0, color ='gray') +geom_point(aes(x = PC1, y = PC2, color = Medalist)) +geom_text_repel(aes(x = PC1, y = PC2,label = Athlete, color = Medalist),size =3, show.legend =FALSE) +geom_point(aes(x = PC1, y = PC2),data = warner_pcs, color ='red', size =3) +geom_text_repel(aes(x = PC1, y = PC2, label = Athlete),data = warner_pcs, color ='red', size =3) +scale_color_manual(values =c('No'='black','Yes'='orange')) +labs(x ='PC1', y ='PC2') +theme_classic(base_size =14)
PC1 PC2 Athlete
1 -3.422699 -0.5092531 Damian Warner (2020)
Based on our analysis Damian Warner’s 2020 performance would not have won a medal if it would’ve happened in 2024. His performance falls into Quadrant III while all medalists (and other non medalists) fall into Quadrant II.
Question 2
Below is a screenshot of a conversation between me and chatbot Claude:
After looking at the graphs, I grew skeptical. So I said:
Behold, Claude’s three data sets which I’ve called claudeA, claudeB, and claudeC:
Each data set has an X and a Y column which represent 2-dimensional variables that we need to rotate.
A)
Scale each data set and plot them side-by-side using the patchwork package. Make sure the aspect ratio of each graph is 1 (i.e., make the height and width of each graph equal). At this point, explain why you think I was skeptical. Specifically, do you think the percent variability explained by the first PC of each data set appears to exceed or fall short of the variability I asked it to?
The 3 plots claim to be pretty different (55% variance, 75% variance, and 90% variance). But they all present as being very similar variance. Specifically plot A should look like a round cloud, when it actually it shows a pretty strong relationship. Also, the directions of the correlations don’t match Claude’s descriptions, since A is negative and B is positive.
B)
Use SVD to find the first PC for each data set, and find the actual percent of total variability explained by each PC using aggregation methods.
get_PCs <- \(df_scaled) { df_svd <-svd(as.matrix(df_scaled)) U <- df_svd$u D <-diag(df_svd$d) U %*% D}PCs_A <-get_PCs(claudeA_scaled)PCs_B <-get_PCs(claudeB_scaled)PCs_C <-get_PCs(claudeC_scaled)head(PCs_A[, 1])
