Tennis player performance can be quantified through a variety of serve and return statistics that contribute to match outcomes. In this project, we analyze the performance metrics of the world’s top 100 male (ATP) tennis players from a recent season to understand what factors distinguish higher-ranked players. By examining serve statistics (such as aces, first serve percentages, and break points saved) alongside return statistics (like return points won and break points converted), we aim to uncover patterns that explain player success. The analysis addresses several key questions: What performance factors correlate most with player rankings? Do top players excel in certain areas more than others? The goal is to provide a comprehensive, data-driven understanding of tennis performance, with findings presented in clear figures for insight.
install.packages(c(
"readr", "car", "corrplot", "fmsb", "ggplot2",
"RColorBrewer", "rpart", "rpart.plot", "psych"
), repos = "https://cran.rstudio.com/")## Installing packages into '/cloud/lib/x86_64-pc-linux-gnu-library/4.4'
## (as 'lib' is unspecified)# Load required packages
library("readr") # For reading data
library("car") # For calculating Variance Inflation Factor (VIF)## Loading required package: carDatalibrary("corrplot") # For visualizing correlation matrices## corrplot 0.95 loadedlibrary("fmsb") # For drawing radar charts
library("ggplot2") # For creating boxplots and other charts
library("grid") # For page layout management
# library("mvstats") # (Optional) For principal component analysis
# library("ggradar") # (Optional) For drawing radar charts
library("RColorBrewer") # For setting color palettes
library("rpart") # For building decision tree models
library("rpart.plot") # For plotting decision trees
library(psych) # For principal component analysis and psychological statistics##
## Attaching package: 'psych'## The following objects are masked from 'package:ggplot2':
##
## %+%, alpha## The following object is masked from 'package:car':
##
## logit1. Data Introduction
Each record includes:
• Ranking and Name
• Number of tournaments played
• Serve Stats: aces, double faults, first serve %, first/second serve points won, break points saved.
• Return Stats: return points won on first/second serves, break points converted.
• Clutch Stats: win rate after winning/losing first set, tiebreak win %, deciding set win %.
The datasets are well-structured, with mostly numeric columns ready for analysis. Minimal data cleaning was required. We standardized column names and ensured data types were numeric. No major missing values or outliers were present beyond the expected range of performance metrics. Thus, apart from understanding and renaming columns, no additional cleaning was necessary – the data accurately reflect each player’s season performance, making it ideal for analysis.
dat_male <- read.csv("./100.csv", fileEncoding = "GBK", sep = ',') # Read data and save as dataset dat_male
# dat_female <- read.csv("/kaggle/input/mmmale/100.csv", fileEncoding = "GBK", sep = ',') # (Optional) Read data and save as dataset dat_female
# summary(dat_female) # Display summary of dat_female
summary(dat_male) # Display summary of dat_male## 排名 姓名 锦标赛 ACES
## Min. : 1.00 Length:100 Min. :15.00 Min. : 7.0
## 1st Qu.: 25.75 Class :character 1st Qu.:22.00 1st Qu.: 118.5
## Median : 50.50 Mode :character Median :24.00 Median : 213.0
## Mean : 50.50 Mean :24.63 Mean : 264.5
## 3rd Qu.: 75.25 3rd Qu.:27.25 3rd Qu.: 340.5
## Max. :100.00 Max. :34.00 Max. :1123.0
## 双误 一发 一发得分 二发得分
## Min. : 12.00 Min. :52.00 Min. :63.00 Min. :43.0
## 1st Qu.: 74.75 1st Qu.:59.00 1st Qu.:69.00 1st Qu.:49.0
## Median :121.50 Median :61.00 Median :72.00 Median :51.0
## Mean :120.73 Mean :60.87 Mean :72.12 Mean :51.2
## 3rd Qu.:162.00 3rd Qu.:64.00 3rd Qu.:75.00 3rd Qu.:53.0
## Max. :287.00 Max. :71.00 Max. :82.00 Max. :62.0
## 挽救破发点 一发回球得分 二发回球得分 成功破发
## Min. :50.00 Min. :18.00 Min. :39.00 Min. :25.00
## 1st Qu.:59.00 1st Qu.:26.75 1st Qu.:48.00 1st Qu.:37.00
## Median :61.00 Median :28.00 Median :49.00 Median :39.00
## Mean :61.42 Mean :28.24 Mean :49.24 Mean :38.99
## 3rd Qu.:64.00 3rd Qu.:30.00 3rd Qu.:51.00 3rd Qu.:42.00
## Max. :73.00 Max. :35.00 Max. :56.00 Max. :53.00
## 抢七 决胜盘 首盘获胜 首盘告负
## Min. : 0.00 Min. : 0.00 Min. : 0.00 Min. : 0.00
## 1st Qu.: 40.38 1st Qu.:39.38 1st Qu.: 71.78 1st Qu.:14.95
## Median : 50.00 Median :52.75 Median : 82.50 Median :21.55
## Mean : 49.70 Mean :49.57 Mean : 79.35 Mean :22.64
## 3rd Qu.: 60.95 3rd Qu.:63.30 3rd Qu.: 88.90 3rd Qu.:28.95
## Max. :100.00 Max. :84.60 Max. :100.00 Max. :75.002. Background Introduction
Problem Statements
1. Key Factors Influencing Player Rankings: Which performance metrics most strongly influence a tennis player’s world ranking? We investigate which statistics (e.g. serve effectiveness, return effectiveness, clutch performance under pressure, etc.) are most associated with higher rankings among the top 100 players.
2. Top Players vs. the Rest: What performance characteristics distinguish the elite (e.g. top 10) players from the rest of the top 100? We explore whether the highest-ranked players have significantly different stats (such as higher serve win percentages or return success rates) compared to players ranked 11–100.
Objectives
• Identify Performance Correlates of Ranking: Determine which performance metrics (serve statistics like aces, first serve points won, etc., and return statistics like return points won, break point conversion rate, etc.) have strong correlations with player ranking.
• Examine Elite vs. Non-Elite Differences: Evaluate differences in performance metrics between the top 10 players and those ranked 11–100. We test whether the elite players have significantly better statistics and interpret what aspects of the game matter most at the elite level.
(I) Comparison between Federer and Nadal
install.packages("IRdisplay")## Installing package into '/cloud/lib/x86_64-pc-linux-gnu-library/4.4'
## (as 'lib' is unspecified)library(IRdisplay)# Extract player data
dat1 <- dat_male[which(dat_male$姓名 == 'Rafael Nadal'), ]
dat2 <- dat_male[which(dat_male$姓名 == 'Roger Federer'), ]
# Set radar chart range (min-max scale for each dimension)
maxmin <- data.frame(part1 = c(100, 0),
part2 = c(100, 0),
part3 = c(100, 0),
part4 = c(100, 0),
part5 = c(100, 0),
part6 = c(100, 0),
part7 = c(100, 0))
# Construct data frame for Rafael Nadal
dat.A <- data.frame(part1 = dat1$一发, # First Serve %
part2 = dat1$成功破发, # Break Points Won
part3 = dat1$二发回球得分, # Return Points on 2nd Serve
part4 = dat1$一发回球得分, # Return Points on 1st Serve
part5 = dat1$挽救破发点, # Break Points Saved
part6 = dat1$二发得分, # Points on 2nd Serve
part7 = dat1$一发得分) # Points on 1st Serve
dat.A2 <- rbind(maxmin, dat.A)
# Construct data frame for Roger Federer
dat.B <- data.frame(part1 = dat2$一发,
part2 = dat2$成功破发,
part3 = dat2$二发回球得分,
part4 = dat2$一发回球得分,
part5 = dat2$挽救破发点,
part6 = dat2$二发得分,
part7 = dat2$一发得分)
dat.B2 <- rbind(maxmin, dat.B)
# Set English labels for radar axes
vlabels_en <- c("First Serve %", "Break Points Won", "Return Points 2nd",
"Return Points 1st", "Break Points Saved",
"Points on 2nd Serve", "Points on 1st Serve")
# Save high-resolution radar chart image
png("radar_fixed.png", width = 1600, height = 800, res = 150)
# Set 1 row, 2 columns layout and Chinese font support
par(mfrow = c(1, 2), family = "STHeiti")
## Rafael Nadal radar chart
col <- rgb(200, 10, 10, 170, max = 255)
radarchart(dat.A2,
axistype = 1,
seg = 5,
pty = 32,
centerzero = TRUE,
axislabcol = 'gray',
pcol = 'lemonchiffon4',
pfcol = col,
cglty = 1,
cglcol = 'gray',
vlabels = vlabels_en,
title = 'Rafael Nadal: Average Stats',
vlcex = 1)
## Roger Federer radar chart
col <- rgb(10, 10, 200, 170, max = 255)
radarchart(dat.B2,
axistype = 1,
seg = 5,
pty = 32,
centerzero = TRUE,
axislabcol = 'gray',
pcol = 'lemonchiffon4',
pfcol = col,
cglty = 1,
cglcol = 'gray',
vlabels = vlabels_en,
title = 'Roger Federer: Average Stats',
vlcex = 1)
# Close PNG device
dev.off()## png
## 2# ✅ Display radar chart in Kaggle notebook
knitr::include_graphics("radar_fixed.png")
# Set radar chart value range: first row is max, second row is min
maxmin <- data.frame(part1 = c(100, 0),
part2 = c(100, 0),
part3 = c(100, 0),
part4 = c(100, 0),
part5 = c(100, 0),
part6 = c(100, 0),
part7 = c(100, 0))
# Calculate average stats for Top 100 male players
dat.A <- data.frame(part1 = mean(dat_male$一发), # First Serve %
part2 = mean(dat_male$成功破发), # Break Points Won
part3 = mean(dat_male$二发回球得分), # Return Points on 2nd Serve
part4 = mean(dat_male$一发回球得分), # Return Points on 1st Serve
part5 = mean(dat_male$挽救破发点), # Break Points Saved
part6 = mean(dat_male$二发得分), # Points on 2nd Serve
part7 = mean(dat_male$一发得分)) # Points on 1st Serve
dat.A2 <- rbind(maxmin, dat.A)
# Set English labels for radar axes
vlabels_en <- c("First Serve %", "Break Points Won", "Return Points 2nd",
"Return Points 1st", "Break Points Saved",
"Points on 2nd Serve", "Points on 1st Serve")
# Save high-resolution radar chart image (for Kaggle output display)
png("radar_male_avg.png", width = 1000, height = 800, res = 150)
# Plotting settings (single chart, with Chinese font support if needed)
par(mfrow = c(1, 1), family = "STHeiti")
# Male player radar chart
col <- rgb(200, 200, 130, 170, max = 255) # Fill color (semi-transparent yellow-green)
leida <- radarchart(dat.A2,
axistype = 1,
seg = 5,
pty = 32,
centerzero = TRUE,
axislabcol = 'gray',
pcol = 'lemonchiffon4',
pfcol = col,
cglty = 1,
cglcol = 'gray',
vlabels = vlabels_en, # ✅ English labels
title = 'Average Technical Stats of\nTop 100 Male Players',
vlcex = 1)
# Close PNG device
dev.off()## png
## 2# ✅ Display the radar chart inline in Kaggle Notebook
knitr::include_graphics("radar_male_avg.png")
# 3. Descriptive analysis
(I) Number of aces and double errors
# Create a new variable "等级" (Tier) based on player rankings
dat_male$等级 <- dat_male$排名 # Initialize the tier variable with rankings
# Assign tier labels based on ranking intervals
dat_male$等级[which(dat_male$排名 >= 1 & dat_male$排名 <= 25)] <- "TOP25"
dat_male$等级[which(dat_male$排名 > 25 & dat_male$排名 <= 50)] <- "TOP25-50"
dat_male$等级[which(dat_male$排名 > 50 & dat_male$排名 <= 75)] <- "TOP50-75"
dat_male$等级[which(dat_male$排名 > 75 & dat_male$排名 <= 100)] <- "TOP75-100"We first examine how aces and double faults vary across players of different rankings (grouped into tiers: Top 25, 26–50, 51–75, 76–100).
# Define custom fill colors
mycolor <- c("lemonchiffon1", "lemonchiffon2",
"lemonchiffon3", "lemonchiffon4")
# Plot 1: Average number of aces per tournament by player tier
aces <- ggplot(dat_male, aes(x = 等级, y = ACES / 锦标赛)) +
geom_boxplot(fill = mycolor) +
labs(
x = 'Player Tier',
y = 'Aces (per tournament)',
title = 'Average Aces per Tournament by Player Tier'
) +
theme_bw() +
ylim(0, 40) +
theme(
plot.title = element_text(hjust = 0.5, size = 14),
text = element_text(family = "STHeiti"), # Font for Chinese characters
axis.title.x = element_text(size = 13),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 9)
)
# Plot 2: Average number of double faults per tournament by player tier
shuangwu <- ggplot(dat_male, aes(x = 等级, y = 双误 / 锦标赛)) +
geom_boxplot(fill = mycolor) +
labs(
x = 'Player Tier',
y = 'Double Faults (per tournament)',
title = 'Average Double Faults per Tournament by Player Tier'
) +
theme_bw() +
ylim(0, 10) +
theme(
plot.title = element_text(hjust = 0.5, size = 14),
text = element_text(family = "STHeiti"),
axis.title.x = element_text(size = 13),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 9)
)
# ✅ Save as high-resolution image (optimized for Kaggle display)
png("boxplot_aces_faults.png", width = 1600, height = 800, res = 150)
# Use grid layout to display two plots side-by-side
grid.newpage()
pushViewport(viewport(width = 1, height = 0.7,
layout = grid.layout(1, 2)))
vplayout <- function(x, y) {
viewport(layout.pos.row = x, layout.pos.col = y)
}
# Print both plots into defined viewports
print(aces, vp = vplayout(1, 1))## Warning: Removed 2 rows containing non-finite outside the scale range
## (`stat_boxplot()`).print(shuangwu, vp = vplayout(1, 2))## Warning: Removed 4 rows containing non-finite outside the scale range
## (`stat_boxplot()`).# Finish saving image
dev.off()## png
## 2# ✅ Display the plot inline in Kaggle
knitr::include_graphics("boxplot_aces_faults.png")
Boxplots of average aces per tournament (left) and double faults per tournament (right) by player tier (men’s data). We observe that higher-ranked male players tend to serve more aces on average. The Top 25 players have a median around 20+ aces per tournament, significantly above lower-ranked tiers, whose medians drop to around 8–12. This trend suggests that a dominant serve (yielding many aces) is a common attribute of top male players. Interestingly, the average double faults per tournament does not increase as sharply for the top players - Top 25 players have slightly higher double fault counts than some lower tiers, but the difference is not as pronounced as for aces. This implies many top players manage to serve aggressively (high aces) without a proportionally large increase in errors. In fact, across all male players there is a positive correlation between total aces and total double faults: those who hit a lot of aces generally also have more double faults, reflecting a risk-reward trade-off in serving. Top players balance this trade-off effectively, maintaining high ace counts while keeping double faults within reasonable levels.
(II) Serving Game
we explore return-game metrics and how they differ by ranking tier for the men’s data.
library(ggplot2)
library(grid)
# Plot 1: Return Points on 1st Serve
a <- ggplot(dat_male, aes(x = 等级, y = 一发回球得分)) +
geom_boxplot(fill = "lemonchiffon2") +
labs(
x = 'Player Tier',
y = 'Return Points on 1st Serve'
) +
theme_bw() +
ylim(20, 40) +
theme(
plot.title = element_text(hjust = 0.5),
text = element_text(family = "STHeiti"), # Font for Chinese support
axis.title.x = element_text(size = 14),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 7)
)
# Plot 2: Return Points on 2nd Serve
b <- ggplot(dat_male, aes(x = 等级, y = 二发回球得分)) +
geom_boxplot(fill = "lemonchiffon3") +
labs(
x = 'Player Tier',
y = 'Return Points on 2nd Serve'
) +
theme_bw() +
ylim(40, 60) +
theme(
plot.title = element_text(hjust = 0.5),
text = element_text(family = "STHeiti"),
axis.title.x = element_text(size = 14),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 7)
)
# Plot 3: Break Points Won
c <- ggplot(dat_male, aes(x = 等级, y = 成功破发)) +
geom_boxplot(fill = "lemonchiffon4") +
labs(
x = 'Player Tier',
y = 'Break Points Won'
) +
theme_bw() +
ylim(20, 60) +
theme(
plot.title = element_text(hjust = 0.5),
text = element_text(family = "STHeiti"),
axis.title.x = element_text(size = 14),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 7)
)
# ✅ Save as high-resolution wide-format image (suitable for Kaggle output)
png("boxplot_returns_breaks.png", width = 1800, height = 700, res = 150)
# Layout plots side-by-side using grid system
grid.newpage()
pushViewport(viewport(width = 1, height = 0.6,
layout = grid.layout(1, 3)))
vplayout <- function(x, y) {
viewport(layout.pos.row = x, layout.pos.col = y)
}
print(a, vp = vplayout(1, 1)) # Plot A: Return Points on 1st Serve## Warning: Removed 1 row containing non-finite outside the scale range
## (`stat_boxplot()`).print(b, vp = vplayout(1, 2)) # Plot B: Return Points on 2nd Serve## Warning: Removed 1 row containing non-finite outside the scale range
## (`stat_boxplot()`).print(c, vp = vplayout(1, 3)) # Plot C: Break Points Won
# Close PNG device
dev.off()## png
## 2# ✅ Display image in Kaggle notebook
knitr::include_graphics("boxplot_returns_breaks.png")
Boxplots show return performance by player tier: return points won on 1st serve (left), 2nd serve (middle), and break points converted (right). Top 25 players consistently outperform lower tiers, winning more return points and converting more break chances.
For example, Top 25 men win about 30% of 1st serve return points, compared to ~25% in the 75–100 tier. On 2nd serves, they win 50–52%, versus mid-40s% for lower tiers. Break point conversion also favors top players—40%+ on average vs. low 30s% for lower ranks.
While these return stats show less dramatic gaps than serve stats, they still reflect the top players’ ability to apply pressure and seize key moments.
In summary, top players differentiate themselves by not only holding serve frequently (thanks to aces and strong serves) but also by winning more points when receiving. The combination of a powerful serve and an effective return game is a hallmark of the highest-ranked players, whereas those ranked lower might struggle particularly in one of these areas (often failing to pressure opponents’ serves enough).
(III) Receive serve situation
# Set output PNG
png("male_return_performance.png", width = 2400, height = 1000, res = 200)
# First Serve Return Points
a <- ggplot(dat_male, aes(x = 等级, y = 一发回球得分)) +
geom_boxplot(fill = "lemonchiffon2") +
labs(x = "Rank", y = "1st Serve Return Points") +
theme_bw() +
ylim(20, 40) +
theme(
plot.title = element_text(hjust = 0.5),
text = element_text(family = "sans"),
axis.title.x = element_text(size = 14),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 7)
)
# Second Serve Return Points
b <- ggplot(dat_male, aes(x = 等级, y = 二发回球得分)) +
geom_boxplot(fill = "lemonchiffon3") +
labs(x = "Rank", y = "2nd Serve Return Points") +
theme_bw() +
ylim(40, 60) +
theme(
plot.title = element_text(hjust = 0.5),
text = element_text(family = "sans"),
axis.title.x = element_text(size = 14),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 7)
)
# Break Points Won
c <- ggplot(dat_male, aes(x = 等级, y = 成功破发)) +
geom_boxplot(fill = "lemonchiffon4") +
labs(x = "Rank", y = "Break Points Won") +
theme_bw() +
ylim(20, 60) +
theme(
plot.title = element_text(hjust = 0.5),
text = element_text(family = "sans"),
axis.title.x = element_text(size = 14),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 7)
)
# 3-panel layout
grid.newpage()
pushViewport(viewport(width = 1, height = 0.5, layout = grid.layout(1, 3)))
vplayout <- function(x, y) viewport(layout.pos.row = x, layout.pos.col = y)
print(a, vp = vplayout(1, 1))## Warning: Removed 1 row containing non-finite outside the scale range
## (`stat_boxplot()`).print(b, vp = vplayout(1, 2))## Warning: Removed 1 row containing non-finite outside the scale range
## (`stat_boxplot()`).print(c, vp = vplayout(1, 3))
dev.off()## png
## 2knitr::include_graphics("male_return_performance.png")
(IV) Winning rate after winning/losing the first set
We analyzed the statistics for match outcomes after winning or losing the first set, across ranking tiers.
# Define custom fill colors for boxplots
mycolor <- c("lemonchiffon1", "lemonchiffon2",
"lemonchiffon3", "lemonchiffon4")
## Boxplot 1: Win rate after winning the first set (by player tier)
shoupan_win <- ggplot(dat_male, aes(x = 等级, y = 首盘获胜)) +
geom_boxplot(fill = mycolor) +
labs(
x = 'Player Tier',
y = 'Win Rate After Winning First Set',
title = 'Win Rate by Tier (After Winning First Set)'
) +
theme_bw() +
ylim(0, 100) +
theme(
plot.title = element_text(hjust = 0.5),
text = element_text(family = "STHeiti"), # Font for Chinese text support
axis.title.x = element_text(size = 14),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 9)
)
## Boxplot 2: Win rate after losing the first set (by player tier)
shoupan_lose <- ggplot(dat_male, aes(x = 等级, y = 首盘告负)) +
geom_boxplot(fill = mycolor) +
labs(
x = 'Player Tier',
y = 'Win Rate After Losing First Set',
title = 'Win Rate by Tier (After Losing First Set)'
) +
theme_bw() +
ylim(0, 100) +
theme(
plot.title = element_text(hjust = 0.5),
text = element_text(family = "STHeiti"),
axis.title.x = element_text(size = 14),
axis.title.y = element_text(size = 12),
axis.text = element_text(size = 9)
)
# ✅ Save plots as a high-resolution image
png("boxplot_set_results.png", width = 1600, height = 800, res = 150)
# Create grid layout for side-by-side display
grid.newpage()
pushViewport(viewport(width = 1, height = 0.6,
layout = grid.layout(1, 2)))
vplayout <- function(x, y) {
viewport(layout.pos.row = x, layout.pos.col = y)
}
print(shoupan_win, vp = vplayout(1, 1)) # Left plot: after winning first set
print(shoupan_lose, vp = vplayout(1, 2)) # Right plot: after losing first set
# Finish saving image
dev.off()## png
## 2# ✅ Display image inline in Kaggle Notebook
knitr::include_graphics("boxplot_set_results.png")
Here the separation is large - Top 25 players still manage to come back and win a match about 30–40% of the time on average after dropping the opening set, whereas those in the bottom tier (75-100) have a median closer to only 10–15%. Many lower-ranked players rarely recover if they start behind. Top players, by contrast, have the self-belief and ability to turn matches around. The spread in the top tier’s boxplot indicates some top players win half of such matches (50%) while a few are lower, but all far exceed the bottom tier. This underscores a psychological and physical edge: elite players are “hard to put away” - even if they start slow, they can fight back, whereas lower-ranked players often cannot reverse momentum. This resilience and clutch factor contributes to their high ranking. In essence, winning the first set is important for everyone, but top players are nearly unbeatable if they start ahead, and also far more dangerous when behind compared to lower-ranked peers.
(V) Analysis of stress resistance types
In the men’s dataset, we further categorized players by how they perform under pressure, using two metrics: Tiebreak win percentage and Deciding set win percentage. We created an English-label “Pressure Type” for each male player: - Strong Under Pressure: Win ≥50% of tiebreaks AND ≥50% of deciding 3rd sets (they excel in high- pressure moments). - Struggles in Deciding Set: Win ≥50% tiebreaks but <50% deciding sets (good in tiebreak shootouts, but falter in longer battles). - Struggles in Tiebreak: Win <50% tiebreaks but ≥50% deciding sets (opposite profile of above). - Weak Under Pressure: Win <50% in both tiebreaks and deciding sets. We then looked at the distribution of these pressure-performance types across ranking tiers.
# Create an English version of the "Pressure Type" variable
dat_male$PressureType <- dat_male$决胜盘 # Initialize using a numeric column as a placeholder
# Assign pressure type categories based on tiebreak and deciding set win rates
dat_male$PressureType[which(dat_male$抢七 >= 50 & dat_male$决胜盘 >= 50)] <- "Strong Under Pressure"
dat_male$PressureType[which(dat_male$抢七 >= 50 & dat_male$决胜盘 < 50)] <- "Struggles in Deciding Set"
dat_male$PressureType[which(dat_male$抢七 < 50 & dat_male$决胜盘 >= 50)] <- "Struggles in Tiebreak"
dat_male$PressureType[which(dat_male$抢七 < 50 & dat_male$决胜盘 < 50)] <- "Weak Under Pressure"
# Convert to ordered factor (to control the display order in plots)
dat_male$PressureType <- factor(dat_male$PressureType,
levels = c("Strong Under Pressure",
"Struggles in Deciding Set",
"Struggles in Tiebreak",
"Weak Under Pressure"))
# Generate a contingency table: PressureType × Tier
counts <- table(dat_male$PressureType, dat_male$等级)
# ✅ Save high-resolution spine plot
png("spine_pressure_type.png", width = 1000, height = 700, res = 150)
par(family = "STHeiti") # Use Chinese font if needed
# Create spine plot (mosaic bar chart) to show distribution of pressure types by tier
spineplot(counts,
xlab = "Player Tier",
ylab = "Proportion",
col = c("khaki", "lemonchiffon2", "lemonchiffon3", "lemonchiffon4"),
main = "Pressure Performance Distribution by Tier")
# Finish saving the image
dev.off()## png
## 2# ✅ Display image inline in Kaggle notebook
knitr::include_graphics("spine_pressure_type.png")
Spine chart showing the proportion of players of each Pressure Performance type in each ranking tier (men). Each column is a tier (Top25, 26-50, 51-75, 76-100), and segments represent what fraction of that tier’s players are in each pressure category. The figure reveals a clear pattern: the Top 25 column is dominated by the darkest segment (Strong Under Pressure), meaning a large proportion of elite players perform well in both tiebreaks and deciding sets. In fact, over half of the Top 25 fell into the “Strong” category, indicating they handle pressure situations exceptionally well. Meanwhile, very few top players are categorized as “Weak Under Pressure.” By contrast, in the lower tiers (especially the 75 - 100 group), the yellow/light segments (indicating struggles under pressure) make up a bigger share. For example, a substantial portion of the bottom tier players were weak in both tiebreaks and final sets, which likely cost them matches that could go either way. The middle categories (struggling in only one type of pressure scenario) are distributed in between.
4. Model establishment
(I) Factor analysis
1. Correlation analysis
We calculated Pearson correlation coefficients among all the performance metrics and with the players’ ranking. (Note: ranking itself is inverse - a lower number is better - so a negative correlation with rank means higher metric values for higher-ranked players).
# ==== 1. Data Cleaning & Standardization ====
# Make a copy of the original data
mydata <- dat_male
# Remove non-modeling columns (robust check for column presence)
cols_to_remove <- intersect(c("排名", "姓名", "锦标赛", "压力类型", "等级"), colnames(mydata))
mydata <- mydata[, !(colnames(mydata) %in% cols_to_remove)]
# Convert ACES and double faults to per-tournament averages
mydata$ACES <- dat_male$ACES / dat_male$锦标赛
mydata$双误 <- dat_male$双误 / dat_male$锦标赛
# ==== 2. Select Numeric Columns & Rename in English ====
# Select all numeric columns
numeric_data <- mydata[sapply(mydata, is.numeric)]
# Replace with English column names (must match the exact column order)
colnames(numeric_data) <- c(
"Aces_per_tournament",
"Double_faults_per_tournament",
"First_Serve%",
"Second_Serve%",
"Break_Points_Won",
"Break_Points_Saved",
"Return_Points_1st",
"Return_Points_2nd",
"WinRate_After_WinSet1",
"WinRate_After_LoseSet1",
"Deciding_Set_Win%",
"Tiebreak_Win%"
)
# ==== 3. Compute Correlation Matrix ====
M <- cor(numeric_data)
# ==== 4. Draw Correlation Heatmap ====
# Save heatmap as high-resolution PNG
png("corrplot_male_players_en.png", width = 1000, height = 1000, res = 150)
corrplot(M,
method = "circle", # Use circles to represent correlations
type = "full", # Show full matrix (both upper and lower triangle)
tl.col = "red", # Red text labels
tl.cex = 1, # Text label size
diag = TRUE, # Show diagonal values
title = "Correlation Matrix of Male Players",
mar = c(0, 0, 2, 0)) # Margin to accommodate the title
dev.off()## png
## 2# ==== 5. Display image in Kaggle Notebook ====
knitr::include_graphics("corrplot_male_players_en.png")
When looking at correlation with Rank, we found that many serve metrics have a negative correlation with rank (blue circles if we included rank in the plot): for instance, total aces had about r ≈ -0.60 with rank, and first serve points won % also significantly negative - meaning better-ranked players (rank 1, 2, etc.) tend to have higher values in those stats 10. For return metrics, we see a moderate negative correlation as well (e.g., Return Points Won % had r ≈ -0.4 to -0.5 with rank for men) 11. Notably, Second Serve % (the percentage of second serves won) and Break Points Saved show strong correlation with other serve stats, hinting they too are important for success. Meanwhile, the clutch metrics (WinRate after Win1stSet, after Lose1stSet, Tiebreak%, Deciding Set%) show positive correlations among themselves and generally a favorable correlation with rank (top players have higher values). These correlations support our earlier observations: high ace counts, high first serve win%, and good clutch performance tend to accompany a top ranking.
2. Factor Analysis
To reduce the many correlated variables into a few underlying factors, we conducted a PCA on the men’s dataset (standardizing the variables).
# Remove the column named "一发" (if it exists)
mydata <- mydata[, !(colnames(mydata) %in% "一发")]
# Ensure only numeric columns are retained for PCA
mydata_numeric <- mydata[sapply(mydata, is.numeric)]
# Perform Principal Component Analysis (with standardization)
pca <- prcomp(mydata_numeric, scale. = TRUE)
# Save scree plot as a high-resolution image
png("scree_plot_pca.png", width = 800, height = 600, res = 150)
# Plot scree plot of principal components
plot(pca, type = "lines", main = "Scree Plot of Principal Components")
abline(h = 1, col = "red", lty = 2) # Kaiser criterion threshold
# Close PNG device
dev.off()## png
## 2# Read the saved image as raw binary (fixes display issues in some environments)
img_raw <- readBin("scree_plot_pca.png", what = "raw", n = file.info("scree_plot_pca.png")$size)
knitr::include_graphics("scree_plot_pca.png")
The scree plot shows that the first two principal components explain about 56.7% of the variance, with an elbow after PC2. Based on the Kaiser criterion (eigenvalue > 1), we retained five components for further analysis.
Varimax-rotated factor analysis revealed intuitive groupings:
Serve Dominance (aces, 1st serve points won, break points saved),
Return Prowess (return points won, break points converted),
Pressure Performance (tiebreak and deciding set stats), with possible minor factors for consistency or endurance.
These composite scores (e.g., ServeFactor, ReturnFactor) were then used as inputs in a classification model to predict ranking tiers. The components align well with tennis expertise and EDA findings.
summary(pca) ## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.029 1.6414 1.00055 0.88213 0.85777 0.82132 0.69460
## Proportion of Variance 0.343 0.2245 0.08342 0.06485 0.06131 0.05621 0.04021
## Cumulative Proportion 0.343 0.5675 0.65096 0.71580 0.77712 0.83333 0.87354
## PC8 PC9 PC10 PC11 PC12
## Standard deviation 0.66886 0.63259 0.53794 0.49705 0.36548
## Proportion of Variance 0.03728 0.03335 0.02412 0.02059 0.01113
## Cumulative Proportion 0.91082 0.94417 0.96828 0.98887 1.00000# Keep only numeric variables
mydata_numeric <- mydata[sapply(mydata, is.numeric)]
# Perform Principal Component Analysis (PCA) with varimax rotation
# Extract 5 components and retain scores
fac5 <- principal(mydata_numeric, nfactors = 5, rotate = "varimax", scores = TRUE)
# Extract eigenvalues (variance explained by each factor)
vars <- fac5$values[1:5]
# Extract variance explained and cumulative variance (as percentages)
vars_prop <- fac5$Vaccounted[2, 1:5] * 100 # Proportion of variance explained
vars_cum <- fac5$Vaccounted[3, 1:5] * 100 # Cumulative variance
# Organize into a summary table
result <- data.frame(
Vars = round(vars, 3), # Eigenvalues
Vars.Prop = round(vars_prop, 3), # % Variance Explained
Vars.Cum = round(vars_cum, 2) # % Cumulative Variance
)
rownames(result) <- paste0("Factor", 1:5)
# Print the result table
print(result)## Vars Vars.Prop Vars.Cum
## Factor1 4.116 23.156 23.16
## Factor2 2.694 19.764 42.92
## Factor3 1.001 13.996 56.92
## Factor4 0.778 11.642 68.56
## Factor5 0.736 9.153 77.71round(cbind(fac5$loadings,fac5$common),3) # Display factor analysis results## RC1 RC2 RC3 RC5 RC4
## ACES 0.864 -0.144 0.226 0.079 0.155
## 双误 0.787 0.285 -0.001 0.212 0.169
## 一发得分 0.761 -0.299 0.128 0.233 0.045
## 二发得分 0.319 0.016 0.814 0.046 -0.132
## 挽救破发点 0.700 -0.161 0.319 0.078 0.037
## 一发回球得分 -0.089 0.875 0.061 -0.099 0.118
## 二发回球得分 -0.134 0.824 0.135 0.154 0.090
## 成功破发 -0.020 0.723 0.053 0.242 -0.031
## 抢七 0.216 0.104 0.062 0.131 0.911
## 决胜盘 0.139 0.153 0.523 0.660 0.252
## 首盘获胜 0.360 0.184 0.027 0.845 0.064
## 首盘告负 0.148 0.344 0.738 0.159 0.3243. Player Type
# 设置因子得分列名
colnames(fac5$scores) <- c("发球因子", "回球因子", "失误压力因子", "获胜压力因子", "平局压力因子")
# 合并为数据框
mydata <- cbind(mydata, fac5$scores)
mydata <- as.data.frame(mydata)
# 添加球员信息
mydata$球员 <- dat_male$姓名
mydata$排名 <- dat_male$排名
mydata$等级 <- dat_male$等级
# 提取发球因子TOP10
faqiu_order <- mydata[order(mydata$发球因子, decreasing = TRUE), ]
top10 <- data.frame(faqiu_order$球员[1:10], faqiu_order$排名[1:10])
colnames(top10) <- c("球员", "世界排名")
print(top10)## 球员 世界排名
## 1 Andy Murray 16
## 2 Novak Djokovic 12
## 3 Grigor Dimitrov 6
## 4 Gilles Muller 25
## 5 Ivo Karlovic 78
## 6 Marin Cilic 5
## 7 Dominic Thiem 4
## 8 Sam Querrey 13
## 9 Benoit Paire 41
## 10 Alexander Zverev 3## Top 10 "Strong Returners" and Their World Rankings
# Sort dataset by the "Return Factor" in descending order
huiqiu_order <- mydata[order(mydata$回球因子, decreasing = TRUE),]
# Display the top 10 players and their rankings
data.frame(
Player_Name = huiqiu_order$球员[1:10],
World_Rank = huiqiu_order$排名[1:10]
)## Player_Name World_Rank
## 1 Diego Schwartzman 26
## 2 Jo-Wilfried Tsonga 15
## 3 Rafael Nadal 1
## 4 Damir Dzumhur 30
## 5 Tomas Berdych 19
## 6 Cedrik-Marcel Stebe 81
## 7 Fernando Verdasco 34
## 8 Hyeon Chung 54
## 9 Nick Kyrgios 21
## 10 Andrey Rublev 37## Top 10 "Strong Returners" and Their World Rankings
# Sort dataset by the "Return Factor" in descending order
huiqiu_order <- mydata[order(mydata$回球因子, decreasing = TRUE),]
# Display the top 10 players and their rankings
data.frame(
Player_Name = huiqiu_order$球员[1:10],
World_Rank = huiqiu_order$排名[1:10]
)## Player_Name World_Rank
## 1 Diego Schwartzman 26
## 2 Jo-Wilfried Tsonga 15
## 3 Rafael Nadal 1
## 4 Damir Dzumhur 30
## 5 Tomas Berdych 19
## 6 Cedrik-Marcel Stebe 81
## 7 Fernando Verdasco 34
## 8 Hyeon Chung 54
## 9 Nick Kyrgios 21
## 10 Andrey Rublev 37## Top 10 Players Who Perform Well Under Winning Pressure and Their World Rankings
# Sort dataset by the "Winning Pressure Factor" in descending order
huosheng_order <- mydata[order(mydata$获胜压力因子, decreasing = TRUE),]
# Display the top 10 players and their world rankings
data.frame(
Player_Name = huosheng_order$球员[1:10],
World_Rank = huosheng_order$排名[1:10]
)## Player_Name World_Rank
## 1 Federico Delbonis 68
## 2 Horacio Zeballos 64
## 3 Victor Estrella Burgos 80
## 4 Marton Fucsovics 84
## 5 Jiri Vesely 63
## 6 Ryan Harrison 47
## 7 Matthew Ebden 100
## 8 Lucas Pouille 18
## 9 Novak Djokovic 12
## 10 Thomas Fabbiano 73## Top 10 Players with Advantage in Tiebreak Situations and Their World Rankings
# Sort dataset by the "Tiebreak Pressure Factor" in descending order
pingju_order <- mydata[order(mydata$平局压力因子, decreasing = TRUE),]
# Display the top 10 players and their world rankings
data.frame(
Player_Name = pingju_order$球员[1:10],
World_Rank = pingju_order$排名[1:10]
)## Player_Name World_Rank
## 1 Tennys Sandgren 85
## 2 Laslo Djere 88
## 3 Rogerio Dutra Silva 93
## 4 Peter Gojowczyk 60
## 5 Donald Young 62
## 6 Juan Martin del Potro 11
## 7 Cedrik-Marcel Stebe 81
## 8 Nikoloz Basilashvili 61
## 9 Jack Sock 9
## 10 Denis Istomin 584. Scores of factors at different levels
library(fmsb)
# ==== Prepare Subsets by Player Tier ====
TOP25_yundongyuan <- mydata[which(mydata$等级 == 'TOP25'), ]
TOP50_yundongyuan <- mydata[which(mydata$等级 == 'TOP25-50'), ]
TOP75_yundongyuan <- mydata[which(mydata$等级 == 'TOP50-75'), ]
TOP100_yundongyuan <- mydata[which(mydata$等级 == 'TOP75-100'), ]
# ==== Compute Average Scores for Each Tier ====
mynewdata <- data.frame(
part1 = c(mean(TOP25_yundongyuan$发球因子 + 1),
mean(TOP50_yundongyuan$发球因子 + 1),
mean(TOP75_yundongyuan$发球因子 + 1),
mean(TOP100_yundongyuan$发球因子 + 1)),
part2 = c(mean(TOP25_yundongyuan$回球因子 + 1),
mean(TOP50_yundongyuan$回球因子 + 1),
mean(TOP75_yundongyuan$回球因子 + 1),
mean(TOP100_yundongyuan$回球因子 + 1)),
part3 = c(mean(TOP25_yundongyuan$失误压力因子 + 1),
mean(TOP50_yundongyuan$失误压力因子 + 1),
mean(TOP75_yundongyuan$失误压力因子 + 1),
mean(TOP100_yundongyuan$失误压力因子 + 1)),
part4 = c(mean(TOP25_yundongyuan$获胜压力因子 + 1),
mean(TOP50_yundongyuan$获胜压力因子 + 1),
mean(TOP75_yundongyuan$获胜压力因子 + 1),
mean(TOP100_yundongyuan$获胜压力因子 + 1)),
part5 = c(mean(TOP25_yundongyuan$平局压力因子 + 1),
mean(TOP50_yundongyuan$平局压力因子 + 1),
mean(TOP75_yundongyuan$平局压力因子 + 1),
mean(TOP100_yundongyuan$平局压力因子 + 1))
)
# ==== Define Radar Chart Value Range ====
maxmin <- data.frame(
part1 = c(2, 0),
part2 = c(2, 0),
part3 = c(2, 0),
part4 = c(2, 0),
part5 = c(2, 0)
)
dat.new2 <- rbind(maxmin, mynewdata)
# ==== Color Settings ====
mycolor <- c('indianred', 'darkorange', 'olivedrab3', 'skyblue3')
# ==== Save Radar Chart as High-Resolution Image ====
png("radar_plot_fixed_legend.png", width = 1200, height = 1000, res = 150)
par(mfrow = c(1, 1), family = "STHeiti", mar = c(2, 2, 5, 2)) # Layout and font settings
# ==== Draw Radar Chart ====
radarchart(dat.new2,
pcol = mycolor, # Line colors
axistype = 0, # No axis baseline
seg = 6, # Number of segments
centerzero = TRUE, # Axis starts from 0
pty = 32,
plwd = 2, # Line width
plty = 1, # Solid lines
cglty = 3, # Grid line type
cglcol = 'gray', # Grid color
vlabels = c("Serve Factor", # Axis labels
"Return Factor",
"Error Pressure",
"Win Pressure",
"Deuce Pressure"),
title = 'Average Factor Scores of Male Tennis Players',
vlcex = 1.2)
# ==== Add Legend at Bottom ====
legend("bottom",
legend = c("TOP25", "TOP25-50", "TOP50-75", "TOP75-100"),
col = mycolor,
lty = 1,
lwd = 2,
horiz = TRUE,
inset = 0.05,
cex = 1.1,
bty = "n")
# Finish saving
dev.off()## png
## 2# ==== Display Image in Kaggle/Jupyter ====
img <- readBin("radar_plot_fixed_legend.png", what = "raw", n = file.info("radar_plot_fixed_legend.png")$size)
knitr::include_graphics("radar_plot_fixed_legend.png")
(II) Decision Tree
We built a decision tree to predict a player’s ranking tier (Top 25, 26-50, 51-75, 76-100) based on the extracted performance factors.
# Load necessary libraries
library(rpart)
library(rpart.plot)
# Set random seed for reproducibility
set.seed(1234)
# ✅ Temporarily map Chinese variable names to English (for modeling only)
mydata$ServeFactor <- mydata$发球因子
mydata$ReturnFactor <- mydata$回球因子
mydata$ErrorPressure <- mydata$失误压力因子
mydata$WinPressure <- mydata$获胜压力因子
mydata$DeucePressure <- mydata$平局压力因子
# ✅ Build decision tree model to predict ranking tier
decision_rpart <- rpart(
等级 ~ ServeFactor + ReturnFactor + ErrorPressure + WinPressure + DeucePressure,
data = mydata
)
# ✅ Save high-resolution decision tree plot
png("decision_tree_model.png", width = 1200, height = 1000, res = 150)
# Plot settings (including font support for Chinese if needed)
par(mfrow = c(1, 1), family = "STHeiti")
rpart.plot(
decision_rpart,
type = 2, # Show all node details
branch = 1,
branch.type = 1,
extra = 104, # Display class, probability, and sample size
shadow.col = "gray80",
box.col = "lemonchiffon2", # Box fill color
border.col = "lemonchiffon4", # Border color
split.col = "gray20", # Split label color
split.cex = 1.3, # Split text size
main = "Decision Tree for Player Ranking" # ✅ Title in English
)
# Close graphics device
dev.off()## png
## 2# ✅ Display the plot in Kaggle/Jupyter notebook
img <- readBin("decision_tree_model.png", what = "raw", n = file.info("decision_tree_model.png")$size)
knitr::include_graphics("decision_tree_model.png")
The decision tree predicts player ranking tier based on five performance factors: ServeFactor, ReturnFactor, ErrorPressure, WinPressure, and DeucePressure.
The root split is on ServeFactor, confirming it as the most important variable. Players with high ServeFactor (≥ 0.036) are mostly classified into the Top25 tier.
If ServeFactor is low, the model checks ReturnFactor next. Players with strong return skills tend to fall into mid-tier (Top25–50), while weak returners are grouped into lower tiers (Top75–100).
Lower-level splits involve pressure-related factors. Among players with similar serve/return stats, those who handle pressure better (e.g., higher ErrorPressure or DeucePressure scores) are predicted to be in higher tiers.
For example, players with strong ServeFactor and high ErrorPressure are very likely in Top25, while those with weaker pressure metrics get further split by DeucePressure or WinPressure to refine classification.