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.
We have varying units (time, distance in meters), and some categories will obviously have much higher raw numbers. Scaling it to Z-score allows fairly weighted distributions.
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?
We can see that PC1 and PC2 account for ~48.415% of our variability in the data.
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.
Based on the loadings, medalists would fall in Quadrant I because the events where higher or lower values indicate better performance mostly contribute to positive PC1 and 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(ggplot2)library(ggrepel)decathlon$PC1 <- scores[,1] #PC 1 and 2decathlon$PC2 <- scores[,2] decathlon$Medal <-factor(decathlon$Medal, levels =c("Gold", "Silver", "Bronze", "None"))ggplot(decathlon, aes(x = PC1, y = PC2, color = Medal)) +geom_point(size =3) +geom_text_repel(aes(label = Athlete), size =3) +# Avoid overlapscale_color_manual(values =c("Gold"="#FFD700", "Silver"="#C0C0C0", # Color-code"Bronze"="#CD7F32", "None"="black")) +labs(title ="Decathlon Athletes on First Two Principal Components",x ="PC1",y ="PC2") +theme_minimal()
To my surprise, the medalists land in Quadrant II. This makes sense, as the competitions differ in if you want high values, like long jump, or low values, such as 100 M hurdles. Depending on what choose as PC1 and PC2 values, the best finishes will be in the second or fourth quadrant.
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.
# Compute mean and SD vectors from 2024 athletesmean_vec_24 <-apply(decathlon_num, 2, mean)sd_vec_24 <-apply(decathlon_num, 2, sd)cat("Mean vector:", mean_vec_24, "\nSD vector:", sd_vec_24, "\n")
# 2024 athletes' PCs pc_scores <- svd_dec$u %*%diag(svd_dec$d)decathlon$PC1_centered <- pc_scores[,1] -mean(pc_scores[,1])decathlon$PC2_centered <- pc_scores[,2] -mean(pc_scores[,2])# Standardize Warner's 2020 results and compute his PCswarner_std <- (warner - mean_vec_24) / sd_vec_24warner_PC <- warner_std %*% svd_dec$v[, 1:2]# Add Warner to datawarner_df <-data.frame(Athlete="Damian Warner 2020",Medal="Warner 2020", PC1_centered=warner_PC[1] -mean(pc_scores[,1]),PC2_centered=warner_PC[2] -mean(pc_scores[,2]))plot_df <-rbind(decathlon[, c("Athlete","Medal","PC1_centered","PC2_centered")], warner_df)# 5. Scatterplot with Damian ggplot(plot_df, aes(x=PC1_centered, y=PC2_centered, color=Medal)) +geom_point(size=3) +geom_text_repel(aes(label=Athlete), size=3) +scale_color_manual(values=c("Gold"="#FFD700","Silver"="#C0C0C0","Bronze"="#CD7F32","None"="gray50","Warner 2020"="black")) +labs(title="Decathlon Athletes (2024) with Damian Warner 2020",x="PC1 (centered)", y="PC2 (centered)") +theme_minimal() +geom_hline(yintercept=0, linetype="dashed") +geom_vline(xintercept=0, linetype="dashed")
Do you think his 2020 performance would have won a medal if it had happened in 2024?
Looking at his point, his PC1 and PC2 don’t seem as close to (-1,1) as others in the dataset. He would definitely be somewhere in the top 10, but winning a medal is unlikely in my opinion.
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?
library(patchwork)# Scale and perform PCAprocess_pca <-function(df) { df_scaled <-scale(df) # center and scale X and Y pca <-prcomp(df_scaled) # PCA rotationdata.frame(PC1 = pca$x[,1], PC2 = pca$x[,2])}# Apply PCA to Claude datasetsclaudeA_pca <-process_pca(claudeA[, c("X","Y")])claudeB_pca <-process_pca(claudeB[, c("X","Y")])claudeC_pca <-process_pca(claudeC[, c("X","Y")])# Plot PCA, with fixed borders and ratioplot_pca <-function(df, title_text) {ggplot(df, aes(x=PC1, y=PC2)) +geom_point() +coord_fixed(ratio=3, xlim=c(-3,3), ylim=c(-1,1)) +# fixed limitslabs(title=title_text, x="PC1", y="PC2") +theme_minimal()}# Individual plotsplotA <-plot_pca(claudeA_pca, "Claude A (PC1 ~55%)")plotB <-plot_pca(claudeB_pca, "Claude B (PC1 ~75%)")plotC <-plot_pca(claudeC_pca, "Claude C (PC1 ~90%)")# Side-by-sidecombined_plot <- plotA + plotB + plotC +plot_layout(widths=c(5,5,5))combined_plot
First off, explaining 90% of variability in only PC1 is not likely, and the data would probably have to be altered in some way to make that work.
Second, the variability looks off. While in plot C, the points seem to be elongated onto PC1, plot A looks very similar, when it should probably be way more varied, especially on the PC2 axis. Also, plot B looks way worse than plot A, even though the data should be tighter on the PC1 and PC 2 axis.
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.
# Function to compute SVD on PC1svd_pc1_variance <-function(df) { df_scaled <-scale(df) # center and scale svd_res <-svd(df_scaled) singular_values <- svd_res$d pc1 <- svd_res$u[,1] * singular_values[1] variance_explained <- (singular_values[1]^2) /sum(singular_values^2) *100list(PC1_scores = pc1, percent_var = variance_explained)}claudeA_svd <-svd_pc1_variance(claudeA[, c("X","Y")])claudeB_svd <-svd_pc1_variance(claudeB[, c("X","Y")])claudeC_svd <-svd_pc1_variance(claudeC[, c("X","Y")])# Print percent variance cat("Claude A: PC1 explains", round(claudeA_svd$percent_var, 1), "% of variance\n")
Claude A: PC1 explains 97.6 % of variance
cat("Claude B: PC1 explains", round(claudeB_svd$percent_var, 1), "% of variance\n")
Claude B: PC1 explains 95.9 % of variance
cat("Claude C: PC1 explains", round(claudeC_svd$percent_var, 1), "% of variance\n")
