Activity 3.2 - PC concepts

SUBMISSION INSTRUCTIONS

1. Render to html
2. Publish your html to RPubs
3. Submit a link to your published solutions

Question 1

The data set we will analyze for this question are on the 10 events in the Men’s 2024 Olympic Decathlon in Paris.

decathlon <- read.csv('Data/mens_decathlon_paris2024.csv')
head(decathlon)

         Athlete  Medal      Nation Overall X100m LongJump ShotPut HighJump
1   Markus Rooth   Gold      Norway    8796 10.71     7.80   15.25     1.99
2 Leo Neugebauer Silver     Germany    8748 10.67     7.98   16.55     2.05
3  Lindon Victor Bronze     Grenada    8711 10.56     7.48   15.71     2.02
4    Sven Roosen   None Netherlands    8607 10.52     7.56   15.10     1.87
5  Janek Õiglane   None     Estonia    8572 10.89     7.25   14.58     1.99
6   Johannes Erm   None     Estonia    8569 10.64     7.66   14.61     2.08
  X400m X110mHurdle Discus PoleVault Javelin X1500m
1 47.69       14.25  49.80       5.3   66.87  279.6
2 47.70       14.51  53.33       5.0   56.64  284.7
3 47.84       14.62  53.91       4.9   68.22  283.5
4 46.40       13.99  46.88       4.7   63.72  258.5
5 48.02       14.45  43.49       5.3   71.89  265.6
6 47.19       14.35  46.29       4.6   59.58  259.7

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.

Even though most of these numbers look like they are measured in the same units, presumably meters, we need to scale this data first because some events are expected to have much higher meter values, so those would affect the output more than they should. It looks like unscaled X1500m has more than 100times more importance than something like highjump.

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?

decathlon_data <- decathlon[, -which(names(decathlon) == "Overall")]

athlete_names <- decathlon$Athlete
event_data <- decathlon_data[, sapply(decathlon_data, is.numeric)]

# Scale the data 
scaled_data <- scale(event_data)

svd_result <- svd(scaled_data)

U <- svd_result$u
D <- svd_result$d
V <- svd_result$v

PC1 <- U[, 1] * D[1]
PC2 <- U[, 2] * D[2]

total_variance <- sum(D^2)
variance_pc1 <- D[1]^2 / total_variance
variance_pc2 <- D[2]^2 / total_variance
variance_first_two <- variance_pc1 + variance_pc2

cat("Variance explained by PC1:", round(variance_pc1 * 100, 2), "%\n")

Variance explained by PC1: 29.13 %

cat("Variance explained by PC2:", round(variance_pc2 * 100, 2), "%\n")

Variance explained by PC2: 19.28 %

cat("Total variance explained by first 2 PCs:", round(variance_first_two * 100, 2), "%\n")

Total variance explained by first 2 PCs: 48.41 %

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.

loadings_pc1 <- V[, 1]
loadings_pc2 <- V[, 2]

loadings_df <- data.frame(
  Event = colnames(event_data),
  PC1 = loadings_pc1,
  PC2 = loadings_pc2
)

print(loadings_df)

         Event          PC1         PC2
1        X100m  0.446612410  0.01678592
2     LongJump -0.493037935 -0.06565628
3      ShotPut -0.309431542  0.53134100
4     HighJump -0.150386291 -0.05665757
5        X400m  0.485973869  0.14847674
6  X110mHurdle  0.345270647  0.31685991
7       Discus -0.139145881  0.59570522
8    PoleVault  0.019829831  0.48083261
9      Javelin  0.252821246  0.03137029
10      X1500m  0.005588625 -0.01948870

# Interpretation for medalists:
# Higher performance in most events means LOWER times (running) or HIGHER distances/heights
# We need to check the sign and magnitude of loadings to determine quadrant

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)

decathlon$PC1 <- PC1
decathlon$PC2 <- PC2

decathlon$Medalist <- ifelse(decathlon$Overall <= 3, "Medalist", "Non-Medalist")

ggplot(decathlon, aes(x = PC1, y = PC2, color = Medalist)) +
  geom_point(size = 3) +
  geom_text(aes(label = Athlete), size = 3, vjust = -0.5, hjust = 0.5) +
  scale_color_manual(values = c("Medalist" = "gold3", "Non-Medalist" = "steelblue")) +
  theme_minimal() +
  labs(title = "PCA of Men's 2024 Olympic Decathlon",
       x = paste0("PC1 (", round(variance_pc1 * 100, 1), "%)"),
       y = paste0("PC2 (", round(variance_pc2 * 100, 1), "%)")) +
  theme(legend.position = "top")

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.

These are his results in the 10 events in 2020

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?

warner <- c(10.12, 8.24, 14.8, 2.02, 47.48, 13.46, 48.67, 4.9, 63.44, 271.08)

mean_vec_24 <- colMeans(event_data)
sd_vec_24 <- apply(event_data, 2, sd)

warner_scaled <- (warner - mean_vec_24) / sd_vec_24

loadings_pc1 <- V[, 1]
loadings_pc2 <- V[, 2]

warner_pc1 <- sum(warner_scaled * loadings_pc1)
warner_pc2 <- sum(warner_scaled * loadings_pc2)

cat("\nWarner's 2020 PC coordinates:\n")

Warner's 2020 PC coordinates:

cat("PC1:", round(warner_pc1, 3), "\n")

PC1: -3.423 

cat("PC2:", round(warner_pc2, 3), "\n")

PC2: -0.509 

cat("\n2024 Medalists' PC coordinates:\n")

2024 Medalists' PC coordinates:

print(decathlon[decathlon$Medalist == "Medalist", c("Athlete", "PC1", "PC2")])

[1] Athlete PC1     PC2    
<0 rows> (or 0-length row.names)

warner_df <- data.frame(
  PC1 = warner_pc1, 
  PC2 = warner_pc2,
  Athlete = "Warner 2020"
)

ggplot(decathlon, aes(x = PC1, y = PC2, color = Medalist)) +
  geom_point(size = 3) +
  geom_text(aes(label = Athlete), size = 3, vjust = -0.5, hjust = 0.5) +
  geom_point(data = warner_df, aes(x = PC1, y = PC2), 
             color = "red", size = 4, shape = 17, inherit.aes = FALSE) +
  geom_text(data = warner_df, aes(x = PC1, y = PC2, label = Athlete), 
            color = "red", size = 3.5, fontface = "bold", vjust = -0.5, inherit.aes = FALSE) +
  scale_color_manual(values = c("Medalist" = "gold3", "Non-Medalist" = "steelblue")) +
  theme_minimal() +
  labs(title = "PCA of Men's 2024 Olympic Decathlon with Warner's 2020 Performance",
       x = paste0("PC1 (", round(variance_pc1 * 100, 1), "%)"),
       y = paste0("PC2 (", round(variance_pc2 * 100, 1), "%)"),
       caption = "Red triangle shows Damian Warner's 2020 gold medal performance") +
  theme(legend.position = "top")

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:

claudeA <- read.csv('Data/claude_dataA.csv')
claudeB <- read.csv('Data/claude_dataB.csv')
claudeC <- read.csv('Data/claude_dataC.csv')
head(claudeA)

   X   Y
1 40 115
2 45 105
3 50 110
4 55  95
5 60 100
6 65  85

head(claudeB)

   X  Y
1 40 50
2 45 55
3 50 48
4 55 60
5 60 53
6 65 65

head(claudeC)

   X   Y
1 40 120
2 45 115
3 50 117
4 55 110
5 60 112
6 65 105

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(ggplot2)
library(patchwork)

claudeA_scaled <- as.data.frame(scale(claudeA))
claudeB_scaled <- as.data.frame(scale(claudeB))
claudeC_scaled <- as.data.frame(scale(claudeC))

plotA <- ggplot(claudeA_scaled, aes(x = X, y = Y)) +
  geom_point(alpha = 0.6, color = "steelblue") +
  coord_fixed(ratio = 1) +
  theme_minimal() +
  labs(title = "Claude Data A (Scaled)",
       x = "X (scaled)", y = "Y (scaled)")

plotB <- ggplot(claudeB_scaled, aes(x = X, y = Y)) +
  geom_point(alpha = 0.6, color = "darkgreen") +
  coord_fixed(ratio = 1) +
  theme_minimal() +
  labs(title = "Claude Data B (Scaled)",
       x = "X (scaled)", y = "Y (scaled)")

plotC <- ggplot(claudeC_scaled, aes(x = X, y = Y)) +
  geom_point(alpha = 0.6, color = "darkred") +
  coord_fixed(ratio = 1) +
  theme_minimal() +
  labs(title = "Claude Data C (Scaled)",
       x = "X (scaled)", y = "Y (scaled)")
plotA | plotB | plotC

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.

calculate_pc1_variance <- function(data_scaled) {
  svd_result <- svd(data_scaled)
    D <- svd_result$d
  
  total_variance <- sum(D^2)
  pc1_variance <- D[1]^2 / total_variance
  
  return(pc1_variance)
}

variance_A <- calculate_pc1_variance(claudeA_scaled)
variance_B <- calculate_pc1_variance(claudeB_scaled)
variance_C <- calculate_pc1_variance(claudeC_scaled)

cat("Percent of total variability explained by PC1:\n")

Percent of total variability explained by PC1:

cat("Dataset A:", round(variance_A * 100, 2), "%\n")

Dataset A: 97.56 %

cat("Dataset B:", round(variance_B * 100, 2), "%\n")

Dataset B: 95.92 %

cat("Dataset C:", round(variance_C * 100, 2), "%\n")

Dataset C: 99.49 %

cat("\n\nDetailed breakdown:\n")

Detailed breakdown:

svd_A <- svd(claudeA_scaled)
cat("\nDataset A:\n")

Dataset A:

cat("Singular values:", round(svd_A$d, 4), "\n")

Singular values: 8.7234 1.379 

cat("Variance explained by PC1:", round(variance_A * 100, 2), "%\n")

Variance explained by PC1: 97.56 %

cat("Variance explained by PC2:", round((svd_A$d[2]^2 / sum(svd_A$d^2)) * 100, 2), "%\n")

Variance explained by PC2: 2.44 %

svd_B <- svd(claudeB_scaled)
cat("\nDataset B:\n")

Dataset B:

cat("Singular values:", round(svd_B$d, 4), "\n")

Singular values: 8.6496 1.7844 

cat("Variance explained by PC1:", round(variance_B * 100, 2), "%\n")

Variance explained by PC1: 95.92 %

cat("Variance explained by PC2:", round((svd_B$d[2]^2 / sum(svd_B$d^2)) * 100, 2), "%\n")

Variance explained by PC2: 4.08 %

svd_C <- svd(claudeC_scaled)
cat("\nDataset C:\n")

Dataset C:

cat("Singular values:", round(svd_C$d, 4), "\n")

Singular values: 8.8093 0.6301 

cat("Variance explained by PC1:", round(variance_C * 100, 2), "%\n")

Variance explained by PC1: 99.49 %

cat("Variance explained by PC2:", round((svd_C$d[2]^2 / sum(svd_C$d^2)) * 100, 2), "%\n")

Variance explained by PC2: 0.51 %