Data Science Project
Chi-Hsiang Yi
06/09/24
Introduction
The purpose of this project is to gauge your technical skills and problem solving ability by working through something similar to a real NBA data science project. You will work your way through this R Markdown document, answering questions as you go along. Please begin by adding your name to the “author” key in the YAML header. When you’re finished with the document, come back and type your answers into the answer key at the top. Please leave all your work below and have your answers where indicated below as well. Please note that we will be reviewing your code so make it clear, concise and avoid long printouts. Feel free to add in as many new code chunks as you’d like.
Remember that we will be grading the quality of your code and visuals alongside the correctness of your answers. Please try to use the tidyverse as much as possible (instead of base R and explicit loops). Please do not bring in any outside data.
Note:
Throughout this document, any season column
represents the year each season started. For example, the 2015-16 season
will be in the dataset as 2015. For most of the rest of the project, we
will refer to a season by just this number (e.g. 2015) instead of the
full text (e.g. 2015-16).
Answers
Part 1
Question 1:
- Offensive: XX.X% eFG
- Defensive: XX.X% eFG
Question 2: XX.X%
Question 3: XX.X%
Question 4: This is a written question. Please leave your response in the document under Question 5.
Question 5: XX.X% of games
Question 6:
- Round 1: XX.X%
- Round 2: XX.X%
- Conference Finals: XX.X%
- Finals: XX.X%
Question 7:
- Percent of +5.0 net rating teams making the 2nd round next year:
XX.X%
- Percent of top 5 minutes played players who played in those 2nd round series: XX.X%
Part 2
Please show your work in the document, you don’t need anything here.
Part 3
Please write your response in the document, you don’t need anything here.
Setup and Data
library(tidyverse)
# Note, you will likely have to change these paths. If your data is in the same folder as this project,
# the paths will likely be fixed for you by deleting ../../Data/awards_project/ from each string.
player_data <- read_csv("player_game_data.csv")
team_data <- read_csv("team_game_data.csv")Part 1 – Data Cleaning
In this section, you’re going to work to answer questions using data from both team and player stats. All provided stats are on the game level.
Question 1
QUESTION: What was the Warriors’ Team offensive and defensive eFG% in the 2015-16 regular season? Remember that this is in the data as the 2015 season.
# Here and for all future questions, feel free to add as many code chunks as you like. Do NOT put echo = F though, we'll want to see your code.
# Filter Warriors' offensive stats during the 2015 regular season (gametype = 2)
warriors_off_data <- team_data %>%
filter(off_team == "GSW", season == 2015, gametype == 2)
# Filter Warriors' defensive stats during the 2015 regular season (gametype = 2)
warriors_def_data <- team_data %>%
filter(def_team == "GSW", season == 2015, gametype == 2)
# Calculate offensive eFG%
offensive_efg <- warriors_off_data %>%
summarise(Off_eFG = ((sum(fgmade) + 0.5 * sum(fg3made)) / sum(fgattempted)) * 100)
# Calculate defensive eFG%
defensive_efg <- warriors_def_data %>%
summarise(Def_eFG = ((sum(fgmade) + 0.5 * sum(fg3made)) / sum(fgattempted)) * 100)
print(round(offensive_efg, 1))## # A tibble: 1 × 1
## Off_eFG
## <dbl>
## 1 56.3print(round(defensive_efg, 1))## # A tibble: 1 × 1
## Def_eFG
## <dbl>
## 1 47.9ANSWER 1:
Offensive: 56.3% eFG
Defensive: 47.9% eFG
Question 2
QUESTION: What percent of the time does the team with the higher eFG% in a given game win that game? Use games from the 2014-2023 regular seasons. If the two teams have an exactly equal eFG%, remove that game from the calculation.
# Calculate eFG% for each row in the dataset
team_data_Q2 <- team_data %>%
mutate(eFG = (fgmade + 0.5 * fg3made) / fgattempted)
# Filter data to regular season games, and arrange the data by game ID and ensure teams in a game are consecutive rows
team_data_filtered_Q2 <- team_data_Q2 %>%
filter(gametype == 2) %>%
arrange(nbagameid, off_home)
# Create a new DataFrame that pairs each two rows (two teams per game)
team_data_paired_Q2 <- team_data_filtered_Q2 %>%
mutate(
opponent_eFG = lead(eFG),
opponent_win = lead(off_win),
same_game = lead(nbagameid) == nbagameid
) %>%
filter(same_game)
# Compare eFG% and determine if the higher eFG% team won
win_analysis_Q2 <- team_data_paired_Q2 %>%
filter(eFG != opponent_eFG) %>% # Exclude games with exactly equal eFG%
summarise(
higher_eFG_win = 100 * mean(
(eFG > opponent_eFG & off_win == 1) | (eFG < opponent_eFG & off_win == 0)
)
)
print(round(win_analysis_Q2, 1))## # A tibble: 1 × 1
## higher_eFG_win
## <dbl>
## 1 81.6ANSWER 2:
81.6%
Question 3
QUESTION: What percent of the time does the team with more offensive rebounds in a given game win that game? Use games from the 2014-2023 regular seasons. If the two teams have an exactly equal number of offensive rebounds, remove that game from the calculation.
# Filter data for only regular season games (gametype == 2) and arrange by game ID and whether the team is home or away
team_data_filtered_Q3 <- team_data %>%
filter(gametype == 2) %>%
arrange(nbagameid, off_home)
# Create a paired dataset where each row has stats for both teams in the same game
team_data_paired_Q3 <- team_data_filtered_Q3 %>%
mutate(
opponent_reboffensive = lead(reboffensive),
opponent_win = lead(off_win),
same_game = lead(nbagameid) == nbagameid
) %>%
filter(same_game)
# Calculate win percentage based on rebound comparison
win_analysis_Q3 <- team_data_paired_Q3 %>%
filter(reboffensive != opponent_reboffensive) %>% # Exclude games with equal offensive rebounds
summarise(
more_rebounds_win_percentage = mean(
(reboffensive > opponent_reboffensive & off_win == 1) | (opponent_reboffensive > reboffensive & off_win == 0)
) * 100
)
print(round(win_analysis_Q3, 1))## # A tibble: 1 × 1
## more_rebounds_win_percentage
## <dbl>
## 1 46.2ANSWER 3:
46.2%
Question 4
QUESTION: Do you have any theories as to why the answer to question 3 is lower than the answer to question 2? Try to be clear and concise with your answer.
ANSWER 4:
The stark contrast in the percentages from questions 2 (81.6%) and 3 (46.2%) can be attributed primarily to the relative impact of shooting efficiency versus rebounding on winning games:
Direct Impact of Scoring: Effective Field Goal Percentage (eFG%) is a direct measure of scoring efficiency, taking into account the added value of three-pointers. High eFG% means a team is not only making more shots but also scoring more points per shot, which is the most straightforward way to win games. The strong correlation (81.6%) underscores that efficiently converting shots into points is crucial in basketball outcomes.
Indirect Benefit of Rebounds: More offensive rebounds indicate more chances to score by extending possessions; however, they are an indirect measure of success. They often result from missed shots, meaning a team is initially failing to score. Consequently, while they provide additional opportunities, they do not guarantee scoring success. The lower correlation (46.2%) suggests that simply obtaining more rebounds does not have as straightforward an impact on winning as shooting efficiently does.
In essence, while offensive rebounds can offer more opportunities, efficient shooting directly translates to scoring, which is more decisive in winning games.
Question 5
QUESTION: Look at players who played at least 25% of their possible games in a season and scored at least 25 points per game played. Of those player-seasons, what percent of games were they available for on average? Use games from the 2014-2023 regular seasons.
For example:
- Ja Morant does not count in the 2023-24 season, as he played just 9
out of 82 games this year, even though he scored 25.1 points per
game.
- Chet Holmgren does not count in the 2023-24 season, as he played all
82 games this year but scored 16.5 points per game.
- LeBron James does count in the 2023-24 season, as he played 71 games and scored 25.7 points per game.
# Calculate the total points and games played per player per season
player_season_stats <- player_data %>%
filter(gametype == 2) %>% # Filter for regular season games
group_by(nbapersonid, season) %>%
summarise(
games_played = n(), # Count of games played
total_points = sum(points), # Sum of points scored
avg_points_per_game = total_points / games_played
) %>%
ungroup()## `summarise()` has grouped output by 'nbapersonid'. You can override using the
## `.groups` argument.# Determine the maximum number of games played in each season
max_games_per_season <- player_season_stats %>%
group_by(season) %>%
summarise(max_games = max(games_played))
player_season_stats <- player_season_stats %>%
left_join(max_games_per_season, by = "season")
# Filter players who meet the criteria: at least 25% of the games and 25 points per game
qualifying_players <- player_season_stats %>%
filter(
games_played >= 0.25 * max_games, # Played at least 25% of the maximum games in that season
avg_points_per_game >= 25 # Averaged at least 25 points per game
)
# Calculate the average percentage of games played for these players
average_participation_percentage <- qualifying_players %>%
summarise(
average_percentage = mean(games_played / max_games * 100)
)
print(round(average_participation_percentage, 1))## # A tibble: 1 × 1
## average_percentage
## <dbl>
## 1 96.1ANSWER 5:
96.1% of games
Question 6
QUESTION: What % of playoff series are won by the team with home court advantage? Give your answer by round. Use playoffs series from the 2014-2022 seasons. Remember that the 2023 playoffs took place during the 2022 season (i.e. 2022-23 season).
team_data_playoffs <- team_data %>%
filter(gametype == 4) %>%
mutate(
series_id = pmin(offensivenbateamid, defensivenbateamid),
series_id2 = pmax(offensivenbateamid, defensivenbateamid),
unique_series_id = paste(series_id, series_id2, sep = "-")
) %>%
select(season, nbagameid, gamedate, off_team_name, def_team_name, off_home, off_win, unique_series_id) %>%
distinct(nbagameid, .keep_all = TRUE) %>%
arrange(season, unique_series_id, gamedate)
# Determine the start and end dates for each series, identify the home court team and series winner
series_info <- team_data_playoffs %>%
group_by(season, unique_series_id) %>%
summarise(
start_date = min(gamedate),
home_court_team = first(if_else(off_home == 1, off_team_name, def_team_name)),
visitor_team = first(if_else(off_home == 0, off_team_name, def_team_name)),
total_games = n(),
series_winner = last(if_else(off_win == 1, off_team_name, def_team_name)),
.groups = 'drop'
) %>%
arrange(season, start_date)
# Add round information based on the sorted series, correcting round assignment for each season
series_info <- series_info %>%
group_by(season) %>%
mutate(
series_rank = row_number(), # Series ranking within each season
round = case_when(
series_rank <= 8 ~ "First Round",
series_rank <= 12 ~ "Second Round",
series_rank <= 14 ~ "Conference Finals",
series_rank == 15 ~ "Finals",
TRUE ~ "Other"
)
) %>%
ungroup()
round_home_advantage <- series_info %>%
filter(round != "Other") %>%
group_by(season, round) %>%
summarise(
total_series = n(),
home_court_advantage_wins = sum(home_court_team == series_winner),
percentage = home_court_advantage_wins / total_series * 100,
.groups = 'drop'
) %>%
group_by(round) %>%
summarise(
average_win_percentage = mean(percentage),
.groups = 'drop'
)
print(round_home_advantage)## # A tibble: 4 × 2
## round average_win_percentage
## <chr> <dbl>
## 1 Conference Finals 55.3
## 2 Finals 73.7
## 3 First Round 78.9
## 4 Second Round 72.4ANSWER 6:
Round 1: 78.9%
Round 2: 72.4%
Conference Finals: 55.2%
Finals: 73.7%
Question 7
QUESTION: Among teams that had at least a +5.0 net rating in the regular season, what percent of them made the second round of the playoffs the following year? Among those teams, what percent of their top 5 total minutes played players (regular season) in the +5.0 net rating season played in that 2nd round playoffs series? Use the 2014-2021 regular seasons to determine the +5 teams and the 2015-2022 seasons of playoffs data.
For example, the Thunder had a better than +5 net rating in the 2023 season. If we make the 2nd round of the playoffs next season (2024-25), we would qualify for this question. Our top 5 minutes played players this season were Shai Gilgeous-Alexander, Chet Holmgren, Luguentz Dort, Jalen Williams, and Josh Giddey. If three of them play in a hypothetical 2nd round series next season, it would count as 3/5 for this question.
Hint: The definition for net rating is in the data dictionary.
# Calculate ORTG and DRTG for regular seasons 2014-2021
teams_net_ratings <- team_data %>%
filter(gametype == 2, season >= 2014, season <= 2021) %>%
group_by(season, off_team_name) %>%
summarize(
ORTG = sum(points) / (sum(possessions) / 100),
.groups = 'drop'
)
team_defensive_stats <- team_data %>%
filter(gametype == 2, season >= 2014, season <= 2021) %>%
group_by(season, def_team_name) %>%
summarise(
total_points_allowed = sum(points),
total_possessions = sum(possessions),
.groups = 'drop'
) %>%
mutate(
DRTG = 100 * (total_points_allowed / total_possessions)
)
# Join the defensive stats back to the offensive stats
teams_net_ratings <- teams_net_ratings %>%
left_join(team_defensive_stats, by = c("season", "off_team_name" = "def_team_name")) %>%
mutate(
NET_RTG = ORTG - DRTG
) %>%
filter(NET_RTG >= 5.0)
# Filter for second round teams from playoffs 2015-2022
second_round_teams <- series_info %>%
filter(round == "Second Round", season >= 2015, season <= 2022) %>%
select(season, home_court_team, visitor_team)
# Identify the +5 teams making it to the second round the next year
qualified_teams <- teams_net_ratings %>%
mutate(next_season = season + 1) %>%
filter(next_season %in% second_round_teams$season) %>%
left_join(second_round_teams, by = c("next_season" = "season")) %>%
filter(off_team_name == home_court_team | off_team_name == visitor_team) %>%
distinct(season, off_team_name, .keep_all = TRUE)## Warning in left_join(., second_round_teams, by = c(next_season = "season")): Detected an unexpected many-to-many relationship between `x` and `y`.
## ℹ Row 1 of `x` matches multiple rows in `y`.
## ℹ Row 1 of `y` matches multiple rows in `x`.
## ℹ If a many-to-many relationship is expected, set `relationship =
## "many-to-many"` to silence this warning.# Calculate the percentage of +5 net rating teams that made it to the second round
percentage_qualified_teams <- nrow(qualified_teams) / nrow(teams_net_ratings) * 100
top_5_players <- player_data %>%
# Join with qualified_teams to filter only relevant seasons and teams
inner_join(qualified_teams, by = c("season", "team_name" = "off_team_name")) %>%
# Group by necessary fields to calculate total minutes
group_by(season, team_name, player_name) %>%
summarize(total_minutes = sum(seconds) / 60, .groups = 'drop') %>%
ungroup() %>%
# Group again to find top 5 players per team per season
group_by(season, team_name) %>%
slice_max(order_by = total_minutes, n = 5, with_ties = FALSE)
# First, prepare the player_data to include a combined key for team matchups
filtered_player_data <- player_data %>%
filter(gametype == 4) %>% # Playoff games only
mutate(team_and_opponent = paste(team_name, opp_team_name, sep = "_"))
# Prepare the qualified_teams data to facilitate correct one-to-many joining
prepared_qualified_teams <- qualified_teams %>%
mutate(home_and_visitor = paste(off_team_name, home_court_team, sep = "_"),
visitor_and_home = paste(off_team_name, visitor_team, sep = "_")) %>%
select(next_season, home_and_visitor, visitor_and_home)
# Join using 'next_season' from 'qualified_teams' and 'season' from 'player_data'
second_round_player_participation <- filtered_player_data %>%
inner_join(prepared_qualified_teams, by = c("season" = "next_season")) %>%
filter(team_and_opponent == home_and_visitor | team_and_opponent == visitor_and_home)## Warning in inner_join(., prepared_qualified_teams, by = c(season = "next_season")): Detected an unexpected many-to-many relationship between `x` and `y`.
## ℹ Row 10408 of `x` matches multiple rows in `y`.
## ℹ Row 16 of `y` matches multiple rows in `x`.
## ℹ If a many-to-many relationship is expected, set `relationship =
## "many-to-many"` to silence this warning.# Adjust the 'season' in top_5_players by adding 1 before the join to match with playoff participation data
top_5_participation <- top_5_players %>%
mutate(season = season + 1) %>% # Shift the season forward by one year to match playoff data
inner_join(second_round_player_participation, by = c("player_name", "team_name", "season")) %>%
group_by(season, team_name, player_name) %>%
summarize(
total_seconds_played = sum(seconds), # Summing up all seconds played in the second round
.groups = 'drop'
)
# Calculate the participation rates
participation_rates <- top_5_participation %>%
group_by(season, team_name) %>%
summarize(
total_top_5 = n(), # Count of top 5 players who participated
.groups = 'drop'
) %>%
mutate(
participation_rate = (total_top_5 / 5) * 100 # Calculate the percentage of participation
)
# Print the participation data
print(participation_rates)## # A tibble: 21 × 4
## season team_name total_top_5 participation_rate
## <dbl> <chr> <int> <dbl>
## 1 2015 Atlanta Hawks 4 80
## 2 2015 Golden State Warriors 5 100
## 3 2015 San Antonio Spurs 5 100
## 4 2016 Cleveland Cavaliers 5 100
## 5 2016 Golden State Warriors 4 80
## 6 2016 San Antonio Spurs 5 100
## 7 2017 Golden State Warriors 5 100
## 8 2017 Houston Rockets 4 80
## 9 2018 Golden State Warriors 5 100
## 10 2018 Houston Rockets 4 80
## # ℹ 11 more rows# Calculate the average participation rate across all teams
total_participation_rate <- participation_rates %>%
summarize(
average_participation_rate = mean(participation_rate)
)
# Print the total participation rate
print(round(total_participation_rate, 1))## # A tibble: 1 × 1
## average_participation_rate
## <dbl>
## 1 82.9ANSWER 7:
Percent of +5.0 net rating teams making the 2nd round next year:
63.6%
Percent of top 5 minutes played players who played in those 2nd round
series: 82.9%
Part 2 – Playoffs Series Modeling
For this part, you will work to fit a model that predicts the winner and the number of games in a playoffs series between any given two teams.
This is an intentionally open ended question, and there are multiple approaches you could take. Here are a few notes and specifications:
Your final output must include the probability of each team winning the series. For example: “Team A has a 30% chance to win and team B has a 70% chance.” instead of “Team B will win.” You must also predict the number of games in the series. This can be probabilistic or a point estimate.
You may use any data provided in this project, but please do not bring in any external sources of data.
You can only use data available prior to the start of the series. For example, you can’t use a team’s stats from the 2016-17 season to predict a playoffs series from the 2015-16 season.
The best models are explainable and lead to actionable insights around team and roster construction. We’re more interested in your thought process and critical thinking than we are in specific modeling techniques. Using smart features is more important than using fancy mathematical machinery.
Include, as part of your answer:
- A brief written overview of how your model works, targeted towards a
decision maker in the front office without a strong statistical
background.
- What you view as the strengths and weaknesses of your model.
- How you’d address the weaknesses if you had more time and/or more
data.
- Apply your model to the 2024 NBA playoffs (2023 season) and create a high quality visual (a table, a plot, or a plotly) showing the 16 teams’ (that made the first round) chances of advancing to each round.
# Calculate offensive statistics for each team per season
team_regular_season_stats <- team_data %>%
filter(gametype == 2) %>%
group_by(season, off_team_name) %>%
summarise(
avg_points = mean(points),
avg_rebounds = mean(reboffensive + rebdefensive),
turnovers_per_game = mean(turnovers),
possessions_per_game = mean(possessions),
ORTG = avg_points / (possessions_per_game / 100),
eFG = (sum(fgmade) + 0.5 * sum(fg3made)) / sum(fgattempted),
TOV_percentage =sum(turnovers) / (sum(fgattempted) + sum(turnovers)),
.groups = 'drop'
)
# Calculate defensive statistics for each team per season
team_defensive_stats <- team_data %>%
filter(gametype == 2) %>%
group_by(season, def_team_name) %>%
summarise(
total_points_allowed = sum(points),
total_possessions = sum(possessions),
avg_points_allowed = mean(points),
.groups = 'drop'
) %>%
mutate(
DRTG = 100 * (total_points_allowed / total_possessions)
)
# Join the defensive stats back to the offensive stats
team_regular_season_stats <- team_regular_season_stats %>%
left_join(team_defensive_stats, by = c("season", "off_team_name" = "def_team_name"))
# Calculate NET_RTG
team_regular_season_stats <- team_regular_season_stats %>%
mutate(
NET_RTG = ORTG - DRTG
)
# Calculate last 15 games statistics for offensive metrics
team_last_15_games_stats <- team_data %>%
filter(gametype == 2) %>%
arrange(season, off_team_name, gamedate) %>%
group_by(season, off_team_name) %>%
slice_tail(n = 15) %>%
summarise(
last_15_avg_points = mean(points),
last_15_avg_rebounds = mean(reboffensive + rebdefensive),
last_15_turnovers_per_game = mean(turnovers),
last_15_possessions_per_game = mean(possessions),
last_15_ORTG = 100 * (last_15_avg_points / last_15_possessions_per_game),
last_15_eFG = (sum(fgmade) + 0.5 * sum(fg3made)) / sum(fgattempted),
last_15_TOV_percentage = 100 * sum(turnovers) / (sum(fgattempted) + sum(turnovers)),
.groups = 'drop'
)
# Calculate last 15 games statistics for defensive metrics
team_last_15_games_def_stats <- team_data %>%
filter(gametype == 2) %>%
arrange(season, def_team_name, gamedate) %>%
group_by(season, def_team_name) %>%
slice_tail(n = 15) %>%
summarise(
last_15_total_points_allowed = sum(points),
last_15_total_possessions = sum(possessions),
last_15_avg_points_allowed = mean(points),
.groups = 'drop'
) %>%
mutate(
last_15_DRTG = 100 * (last_15_total_points_allowed / last_15_total_possessions)
)
# Merge the defensive stats back into the offensive stats for the last 15 games
team_last_15_games_stats <- team_last_15_games_stats %>%
left_join(team_last_15_games_def_stats, by = c("season", "off_team_name" = "def_team_name"))
# Calculate NET_RTG for the last 15 games
team_last_15_games_stats <- team_last_15_games_stats %>%
mutate(
last_15_NET_RTG = last_15_ORTG - last_15_DRTG
)
# Merge regular season stats into the series info for both home and visitor teams
series_info_playoff_model <- series_info %>%
filter(season >= 2014, season <= 2023)
# Join regular season and last 15 games stats for home and visitor teams
series_info_playoff_model <- series_info_playoff_model %>%
left_join(team_regular_season_stats, by = c("home_court_team" = "off_team_name", "season" = "season"), suffix = c("", "_home")) %>%
left_join(team_regular_season_stats, by = c("visitor_team" = "off_team_name", "season" = "season"), suffix = c("_home", "_visitor")) %>%
left_join(team_last_15_games_stats, by = c("home_court_team" = "off_team_name", "season" = "season"), suffix = c("", "_home")) %>%
left_join(team_last_15_games_stats, by = c("visitor_team" = "off_team_name", "season" = "season"), suffix = c("_home", "_visitor")) %>%
mutate(
points_diff = avg_points_home - avg_points_visitor,
rebounds_diff = avg_rebounds_home - avg_rebounds_visitor,
turnovers_diff = turnovers_per_game_home - turnovers_per_game_visitor,
possessions_diff = possessions_per_game_home - possessions_per_game_visitor,
ORTG_diff = ORTG_home - ORTG_visitor,
DRTG_diff = DRTG_home - DRTG_visitor,
NET_RTG_diff = NET_RTG_home - NET_RTG_visitor,
TOV_percentage_diff = TOV_percentage_home - TOV_percentage_visitor,
eFG_diff = eFG_home - eFG_visitor,
last_15_points_diff = last_15_avg_points_home - last_15_avg_points_visitor,
last_15_rebounds_diff = last_15_avg_rebounds_home - last_15_avg_rebounds_visitor,
last_15_turnovers_diff = last_15_turnovers_per_game_home - last_15_turnovers_per_game_visitor,
last_15_possessions_diff = last_15_possessions_per_game_home - last_15_possessions_per_game_visitor,
last_15_ORTG_diff = last_15_ORTG_home - last_15_ORTG_visitor,
last_15_DRTG_diff = last_15_DRTG_home - last_15_DRTG_visitor,
last_15_NET_RTG_diff = last_15_NET_RTG_home - last_15_NET_RTG_visitor,
last_15_TOV_percentage_diff = last_15_TOV_percentage_home - last_15_TOV_percentage_visitor,
last_15_eFG_diff = last_15_eFG_home - last_15_eFG_visitor,
home_win = if_else(series_winner == home_court_team, 1, 0),
visitor_win = if_else(series_winner == visitor_team, 1, 0)
)
library(caret)## Loading required package: lattice##
## Attaching package: 'caret'## The following object is masked from 'package:purrr':
##
## liftset.seed(123) # for reproducibility
# 1. Using a simple logistic regression gain preliminary insights into the prediction task. Predictors: winner_label ~ points_diff + rebounds_diff + TOV_percentage_diff + possessions_diff + ORTG_diff + NET_RTG_diff + eFG_diff
# Prepare training and testing datasets using createDataPartition
train_index <- createDataPartition(series_info_playoff_model$series_winner == series_info_playoff_model$home_court_team, p = 0.75, list = FALSE)
train_data <- series_info_playoff_model[train_index, ]
test_data <- series_info_playoff_model[-train_index, ]
# Update the training and testing datasets
train_data$winner_label <- factor(train_data$home_win, levels = c(0, 1), labels = c("VisitorWin", "HomeWin"))
test_data$winner_label <- factor(test_data$home_win, levels = c(0, 1), labels = c("VisitorWin", "HomeWin"))
train_control <- trainControl(method = "cv", number = 10, savePredictions = "final", classProbs = TRUE)
# Define the numeric predictors used for the model
numeric_predictors <- c("points_diff", "rebounds_diff", "turnovers_diff", "possessions_diff", "ORTG_diff", "DRTG_diff", "NET_RTG_diff",
"TOV_percentage_diff", "eFG_diff", "last_15_points_diff", "last_15_rebounds_diff", "last_15_turnovers_diff",
"last_15_possessions_diff", "last_15_ORTG_diff", "last_15_DRTG_diff", "last_15_NET_RTG_diff",
"last_15_TOV_percentage_diff", "last_15_eFG_diff")
# Calculate correlation matrix among numeric predictors
cor_matrix <- cor(train_data[, numeric_predictors, drop = FALSE])
print(cor_matrix)## points_diff rebounds_diff turnovers_diff
## points_diff 1.00000000 0.07075167 0.20873918
## rebounds_diff 0.07075167 1.00000000 -0.11329744
## turnovers_diff 0.20873918 -0.11329744 1.00000000
## possessions_diff 0.81375759 0.21901752 0.46245271
## ORTG_diff 0.80893014 -0.10830823 -0.12259658
## DRTG_diff 0.21875459 0.16091046 -0.29634902
## NET_RTG_diff 0.55999350 -0.24890178 0.15580439
## TOV_percentage_diff 0.01678957 -0.30866164 0.95178991
## eFG_diff 0.70393786 -0.52346748 0.33900864
## last_15_points_diff 0.67896349 0.26758911 0.04655322
## last_15_rebounds_diff 0.13580778 0.71798437 -0.06024023
## last_15_turnovers_diff 0.12941710 -0.09424227 0.71075874
## last_15_possessions_diff 0.66137321 0.35257026 0.32434885
## last_15_ORTG_diff 0.36854740 0.06517895 -0.19393552
## last_15_DRTG_diff 0.06697481 0.07479079 -0.28005104
## last_15_NET_RTG_diff 0.25171371 -0.00726728 0.06894005
## last_15_TOV_percentage_diff -0.04133979 -0.26856084 0.66326037
## last_15_eFG_diff 0.38792595 -0.28281032 0.16307337
## possessions_diff ORTG_diff DRTG_diff
## points_diff 0.81375759 0.80893014 0.21875459
## rebounds_diff 0.21901752 -0.10830823 0.16091046
## turnovers_diff 0.46245271 -0.12259658 -0.29634902
## possessions_diff 1.00000000 0.31707512 -0.06101096
## ORTG_diff 0.31707512 1.00000000 0.41839594
## DRTG_diff -0.06101096 0.41839594 1.00000000
## NET_RTG_diff 0.35369744 0.55695523 -0.52132468
## TOV_percentage_diff 0.24318479 -0.21361818 -0.30755918
## eFG_diff 0.47974283 0.66585095 0.04526807
## last_15_points_diff 0.58682549 0.51487137 0.24466997
## last_15_rebounds_diff 0.21717717 -0.00198261 0.16388475
## last_15_turnovers_diff 0.27264987 -0.06392060 -0.25827735
## last_15_possessions_diff 0.81139688 0.25578183 0.03057123
## last_15_ORTG_diff 0.12801804 0.47533315 0.29451786
## last_15_DRTG_diff -0.13275660 0.24644164 0.73827903
## last_15_NET_RTG_diff 0.21578841 0.19296990 -0.36217632
## last_15_TOV_percentage_diff 0.08657967 -0.15339250 -0.28438055
## last_15_eFG_diff 0.24537192 0.38794466 0.02462870
## NET_RTG_diff TOV_percentage_diff eFG_diff
## points_diff 0.5599935 0.01678957 0.70393786
## rebounds_diff -0.2489018 -0.30866164 -0.52346748
## turnovers_diff 0.1558044 0.95178991 0.33900864
## possessions_diff 0.3536974 0.24318479 0.47974283
## ORTG_diff 0.5569552 -0.21361818 0.66585095
## DRTG_diff -0.5213247 -0.30755918 0.04526807
## NET_RTG_diff 1.0000000 0.08053610 0.58420461
## TOV_percentage_diff 0.0805361 1.00000000 0.30699240
## eFG_diff 0.5842046 0.30699240 1.00000000
## last_15_points_diff 0.2600134 -0.13154623 0.31617102
## last_15_rebounds_diff -0.1517235 -0.22428716 -0.28607855
## last_15_turnovers_diff 0.1761195 0.66870085 0.25085152
## last_15_possessions_diff 0.2123642 0.10049595 0.31587977
## last_15_ORTG_diff 0.1772830 -0.24944488 0.17082154
## last_15_DRTG_diff -0.4435591 -0.26868250 0.01402493
## last_15_NET_RTG_diff 0.5124886 0.01337655 0.13066924
## last_15_TOV_percentage_diff 0.1159258 0.70934202 0.21221060
## last_15_eFG_diff 0.3419715 0.15060120 0.52982469
## last_15_points_diff last_15_rebounds_diff
## points_diff 0.67896349 0.13580778
## rebounds_diff 0.26758911 0.71798437
## turnovers_diff 0.04655322 -0.06024023
## possessions_diff 0.58682549 0.21717717
## ORTG_diff 0.51487137 -0.00198261
## DRTG_diff 0.24466997 0.16388475
## NET_RTG_diff 0.26001340 -0.15172353
## TOV_percentage_diff -0.13154623 -0.22428716
## eFG_diff 0.31617102 -0.28607855
## last_15_points_diff 1.00000000 0.03749135
## last_15_rebounds_diff 0.03749135 1.00000000
## last_15_turnovers_diff -0.05233709 -0.09764938
## last_15_possessions_diff 0.65205685 0.40436373
## last_15_ORTG_diff 0.79738959 -0.27778908
## last_15_DRTG_diff 0.18243209 0.03537911
## last_15_NET_RTG_diff 0.51373716 -0.26036177
## last_15_TOV_percentage_diff -0.23097554 -0.32210713
## last_15_eFG_diff 0.62610159 -0.64077279
## last_15_turnovers_diff last_15_possessions_diff
## points_diff 0.12941710 0.66137321
## rebounds_diff -0.09424227 0.35257026
## turnovers_diff 0.71075874 0.32434885
## possessions_diff 0.27264987 0.81139688
## ORTG_diff -0.06392060 0.25578183
## DRTG_diff -0.25827735 0.03057123
## NET_RTG_diff 0.17611951 0.21236415
## TOV_percentage_diff 0.66870085 0.10049595
## eFG_diff 0.25085152 0.31587977
## last_15_points_diff -0.05233709 0.65205685
## last_15_rebounds_diff -0.09764938 0.40436373
## last_15_turnovers_diff 1.00000000 0.36304740
## last_15_possessions_diff 0.36304740 1.00000000
## last_15_ORTG_diff -0.35418690 0.06331377
## last_15_DRTG_diff -0.30789095 -0.04091491
## last_15_NET_RTG_diff -0.04156448 0.08636747
## last_15_TOV_percentage_diff 0.94390710 0.11394975
## last_15_eFG_diff 0.12824988 0.14551710
## last_15_ORTG_diff last_15_DRTG_diff
## points_diff 0.36854740 0.06697481
## rebounds_diff 0.06517895 0.07479079
## turnovers_diff -0.19393552 -0.28005104
## possessions_diff 0.12801804 -0.13275660
## ORTG_diff 0.47533315 0.24644164
## DRTG_diff 0.29451786 0.73827903
## NET_RTG_diff 0.17728304 -0.44355909
## TOV_percentage_diff -0.24944488 -0.26868250
## eFG_diff 0.17082154 0.01402493
## last_15_points_diff 0.79738959 0.18243209
## last_15_rebounds_diff -0.27778908 0.03537911
## last_15_turnovers_diff -0.35418690 -0.30789095
## last_15_possessions_diff 0.06331377 -0.04091491
## last_15_ORTG_diff 1.00000000 0.26999770
## last_15_DRTG_diff 0.26999770 1.00000000
## last_15_NET_RTG_diff 0.61037067 -0.59789883
## last_15_TOV_percentage_diff -0.39071189 -0.30180899
## last_15_eFG_diff 0.71237425 0.03189038
## last_15_NET_RTG_diff last_15_TOV_percentage_diff
## points_diff 0.25171371 -0.04133979
## rebounds_diff -0.00726728 -0.26856084
## turnovers_diff 0.06894005 0.66326037
## possessions_diff 0.21578841 0.08657967
## ORTG_diff 0.19296990 -0.15339250
## DRTG_diff -0.36217632 -0.28438055
## NET_RTG_diff 0.51248860 0.11592585
## TOV_percentage_diff 0.01337655 0.70934202
## eFG_diff 0.13066924 0.21221060
## last_15_points_diff 0.51373716 -0.23097554
## last_15_rebounds_diff -0.26036177 -0.32210713
## last_15_turnovers_diff -0.04156448 0.94390710
## last_15_possessions_diff 0.08636747 0.11394975
## last_15_ORTG_diff 0.61037067 -0.39071189
## last_15_DRTG_diff -0.59789883 -0.30180899
## last_15_NET_RTG_diff 1.00000000 -0.07697459
## last_15_TOV_percentage_diff -0.07697459 1.00000000
## last_15_eFG_diff 0.56680880 0.14837453
## last_15_eFG_diff
## points_diff 0.38792595
## rebounds_diff -0.28281032
## turnovers_diff 0.16307337
## possessions_diff 0.24537192
## ORTG_diff 0.38794466
## DRTG_diff 0.02462870
## NET_RTG_diff 0.34197150
## TOV_percentage_diff 0.15060120
## eFG_diff 0.52982469
## last_15_points_diff 0.62610159
## last_15_rebounds_diff -0.64077279
## last_15_turnovers_diff 0.12824988
## last_15_possessions_diff 0.14551710
## last_15_ORTG_diff 0.71237425
## last_15_DRTG_diff 0.03189038
## last_15_NET_RTG_diff 0.56680880
## last_15_TOV_percentage_diff 0.14837453
## last_15_eFG_diff 1.00000000highlyCorrelated <- findCorrelation(cor_matrix, cutoff = 0.75)
# Get the names of highly correlated features
highlyCorrelated_names <- colnames(cor_matrix)[highlyCorrelated]
# Print the names of highly correlated features
print(highlyCorrelated_names)## [1] "last_15_points_diff" "points_diff"
## [3] "turnovers_diff" "last_15_TOV_percentage_diff"
## [5] "last_15_possessions_diff"# Define the model formula
# formula <- winner_label ~ points_diff + rebounds_diff + turnovers_diff + possessions_diff + ORTG_diff + DRTG_diff + NET_RTG_diff
updated_formula <- winner_label ~ points_diff + rebounds_diff + TOV_percentage_diff + possessions_diff + ORTG_diff + NET_RTG_diff + eFG_diff
# Training the model
# logistic_model <- train(formula, data = train_data, method = "glm", family = "binomial", trControl = train_control)
updated_model <- train(updated_formula, data = train_data, method = "glm", family = "binomial", trControl = train_control)
# Summary of the model
summary(updated_model)##
## Call:
## NULL
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.0713 -0.4627 0.4300 0.7536 1.6825
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 0.62804 0.38087 1.649 0.0992 .
## points_diff 1.67105 2.95652 0.565 0.5719
## rebounds_diff -0.19963 0.21063 -0.948 0.3432
## TOV_percentage_diff 54.67805 28.78195 1.900 0.0575 .
## possessions_diff -1.98241 3.33974 -0.594 0.5528
## ORTG_diff -1.34302 2.86610 -0.469 0.6394
## NET_RTG_diff 0.05447 0.11813 0.461 0.6447
## eFG_diff 0.73619 32.87795 0.022 0.9821
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 115.802 on 101 degrees of freedom
## Residual deviance: 94.359 on 94 degrees of freedom
## AIC: 110.36
##
## Number of Fisher Scoring iterations: 5# Only coefficient with p-value close to 0.05 is TOV_percentage_diff, indicating that the features are not explanatory of winning
# Predict on the test data using the updated model
updated_predictions <- predict(updated_model, newdata = test_data, type = "prob")
# Convert probabilities to factor labels based on a threshold
predicted_labels <- factor(ifelse(updated_predictions[, "HomeWin"] > 0.5, "HomeWin", "VisitorWin"),
levels = levels(test_data$winner_label))
# Now you can use these labels in the confusion matrix
updated_conf_matrix <- confusionMatrix(predicted_labels, test_data$winner_label, positive = "HomeWin")
print(updated_conf_matrix)## Confusion Matrix and Statistics
##
## Reference
## Prediction VisitorWin HomeWin
## VisitorWin 3 3
## HomeWin 5 22
##
## Accuracy : 0.7576
## 95% CI : (0.5774, 0.8891)
## No Information Rate : 0.7576
## P-Value [Acc > NIR] : 0.5934
##
## Kappa : 0.2787
##
## Mcnemar's Test P-Value : 0.7237
##
## Sensitivity : 0.8800
## Specificity : 0.3750
## Pos Pred Value : 0.8148
## Neg Pred Value : 0.5000
## Prevalence : 0.7576
## Detection Rate : 0.6667
## Detection Prevalence : 0.8182
## Balanced Accuracy : 0.6275
##
## 'Positive' Class : HomeWin
## # The model correctly identified the outcome for home wins (sensitivity: 88.00%) better than for visitor wins (specificity: 37.50%).
# Which could be due to the imbalanced dataset. While the model achieved moderate accuracy, the lack of statistically significant coefficients suggests that the included predictors may not sufficiently capture the complexities of determining game outcomes.
# The next part adds more features to see if it improves the results.
# 2. Adding recent performance metrics that might enhance predictability (Last 15 game performance prior to playoffs)
# Splitting data into training and testing
set.seed(123) # for reproducibility
train_index <- createDataPartition(series_info_playoff_model$home_win, p = 0.75, list = FALSE)
train_data <- series_info_playoff_model[train_index, ]
test_data <- series_info_playoff_model[-train_index, ]
# Update the training and testing datasets
train_data$winner_label <- factor(train_data$home_win, levels = c(0, 1), labels = c("VisitorWin", "HomeWin"))
test_data$winner_label <- factor(test_data$home_win, levels = c(0, 1), labels = c("VisitorWin", "HomeWin"))
# Calculate correlation matrix among predictors
predictors <- train_data[, c("points_diff", "rebounds_diff", "turnovers_diff", "possessions_diff", "ORTG_diff", "DRTG_diff", "NET_RTG_diff", "TOV_percentage_diff", "eFG_diff",
"last_15_points_diff", "last_15_rebounds_diff", "last_15_turnovers_diff", "last_15_possessions_diff", "last_15_ORTG_diff", "last_15_DRTG_diff", "last_15_NET_RTG_diff", "last_15_TOV_percentage_diff", "last_15_eFG_diff")]
# Calculate correlation matrix among numeric predictors
cor_matrix <- cor(predictors)
highlyCorrelated <- findCorrelation(cor_matrix, cutoff = 0.75)
# Get the names of highly correlated features
highlyCorrelated_names <- colnames(cor_matrix)[highlyCorrelated]
# Print the names of highly correlated features
print(highlyCorrelated_names)## [1] "last_15_points_diff" "points_diff"
## [3] "turnovers_diff" "last_15_TOV_percentage_diff"
## [5] "last_15_possessions_diff"# Define model formulas
# formula_season_long <- winner_label ~ points_diff + rebounds_diff + turnovers_diff + possessions_diff + ORTG_diff + DRTG_diff + NET_RTG_diff
formula_season_long <- winner_label ~ points_diff + rebounds_diff + turnovers_diff + possessions_diff + ORTG_diff + NET_RTG_diff + eFG_diff
# formula_last_15_games <- winner_label ~ points_diff + rebounds_diff + turnovers_diff + possessions_diff + ORTG_diff + DRTG_diff + NET_RTG_diff +
# last_15_points_diff + last_15_rebounds_diff + last_15_turnovers_diff + last_15_possessions_diff + last_15_ORTG_diff + last_15_DRTG_diff + last_15_NET_RTG_diff
formula_last_15_games <- winner_label ~ points_diff + rebounds_diff + turnovers_diff + possessions_diff + ORTG_diff + NET_RTG_diff + eFG_diff +
last_15_points_diff + last_15_rebounds_diff + last_15_turnovers_diff + last_15_possessions_diff + last_15_ORTG_diff + last_15_NET_RTG_diff + last_15_eFG_diff
# Training control
train_control <- trainControl(method = "cv", number = 10, savePredictions = "final", classProbs = TRUE)
# Train the first model using season-long stats
model_season_long <- train(formula_season_long, data = train_data, method = "glm", family = "binomial", trControl = train_control)
# Train the second model using season-long and last 15 games stats
model_last_15_games <- train(formula_last_15_games, data = train_data, method = "glm", family = "binomial", trControl = train_control)
# Predict on the test data using the first model (season-long stats)
predictions_season_long <- predict(model_season_long, newdata = test_data, type = "prob")
predicted_labels_season_long <- factor(ifelse(predictions_season_long[, "HomeWin"] > 0.5, "HomeWin", "VisitorWin"),
levels = levels(test_data$winner_label))
# Predict on the test data using the second model (season-long and last 15 games stats)
predictions_last_15_games <- predict(model_last_15_games, newdata = test_data, type = "prob")
predicted_labels_last_15_games <- factor(ifelse(predictions_last_15_games[, "HomeWin"] > 0.5, "HomeWin", "VisitorWin"),
levels = levels(test_data$winner_label))
# Evaluate the accuracy of the first model
conf_matrix_season_long <- confusionMatrix(predicted_labels_season_long, test_data$winner_label)
print("Confusion Matrix for Model Using Season-Long Stats:")## [1] "Confusion Matrix for Model Using Season-Long Stats:"print(conf_matrix_season_long)## Confusion Matrix and Statistics
##
## Reference
## Prediction VisitorWin HomeWin
## VisitorWin 3 3
## HomeWin 5 22
##
## Accuracy : 0.7576
## 95% CI : (0.5774, 0.8891)
## No Information Rate : 0.7576
## P-Value [Acc > NIR] : 0.5934
##
## Kappa : 0.2787
##
## Mcnemar's Test P-Value : 0.7237
##
## Sensitivity : 0.37500
## Specificity : 0.88000
## Pos Pred Value : 0.50000
## Neg Pred Value : 0.81481
## Prevalence : 0.24242
## Detection Rate : 0.09091
## Detection Prevalence : 0.18182
## Balanced Accuracy : 0.62750
##
## 'Positive' Class : VisitorWin
## # Evaluate the accuracy of the second model
conf_matrix_last_15_games <- confusionMatrix(predicted_labels_last_15_games, test_data$winner_label)
print("Confusion Matrix for Model Using Last 15 Games Stats:")## [1] "Confusion Matrix for Model Using Last 15 Games Stats:"print(conf_matrix_last_15_games)## Confusion Matrix and Statistics
##
## Reference
## Prediction VisitorWin HomeWin
## VisitorWin 4 2
## HomeWin 4 23
##
## Accuracy : 0.8182
## 95% CI : (0.6454, 0.9302)
## No Information Rate : 0.7576
## P-Value [Acc > NIR] : 0.2791
##
## Kappa : 0.459
##
## Mcnemar's Test P-Value : 0.6831
##
## Sensitivity : 0.5000
## Specificity : 0.9200
## Pos Pred Value : 0.6667
## Neg Pred Value : 0.8519
## Prevalence : 0.2424
## Detection Rate : 0.1212
## Detection Prevalence : 0.1818
## Balanced Accuracy : 0.7100
##
## 'Positive' Class : VisitorWin
## # Comparing model accuracies directly
accuracy_season_long <- conf_matrix_season_long$overall['Accuracy']
accuracy_last_15_games <- conf_matrix_last_15_games$overall['Accuracy']
print(paste("Accuracy of Model Using Season-Long Stats:", accuracy_season_long))## [1] "Accuracy of Model Using Season-Long Stats: 0.757575757575758"print(paste("Accuracy of Model Using Last 15 Games Stats:", accuracy_last_15_games))## [1] "Accuracy of Model Using Last 15 Games Stats: 0.818181818181818"# Additional comparisons can be made using Sensitivity, Specificity, etc.
sensitivity_season_long <- conf_matrix_season_long$byClass['Sensitivity']
sensitivity_last_15_games <- conf_matrix_last_15_games$byClass['Sensitivity']
specificity_season_long <- conf_matrix_season_long$byClass['Specificity']
specificity_last_15_games <- conf_matrix_last_15_games$byClass['Specificity']
print(paste("Sensitivity of Model Using Season-Long Stats:", sensitivity_season_long))## [1] "Sensitivity of Model Using Season-Long Stats: 0.375"print(paste("Sensitivity of Model Using Last 15 Games Stats:", sensitivity_last_15_games))## [1] "Sensitivity of Model Using Last 15 Games Stats: 0.5"print(paste("Specificity of Model Using Season-Long Stats:", specificity_season_long))## [1] "Specificity of Model Using Season-Long Stats: 0.88"print(paste("Specificity of Model Using Last 15 Games Stats:", specificity_last_15_games))## [1] "Specificity of Model Using Last 15 Games Stats: 0.92"# The model utilizing last 15 games features achieved an accuracy of 81.82%, outperforming the season-long stats model with an accuracy of 75.76%.
# Moreover, the sensitivity of the last 15 games model (50.00%) surpassed that of the season-long model (37.50%), indicating a better ability to correctly identify home wins.
# Similarly, the last 15 games model exhibited higher specificity (92.00%) compared to the season-long model (88.00%), suggesting improved recognition of visitor wins.
# These results imply that recent team form, as captured by the last 15 games' performance metrics, provides valuable insights for predicting playoff outcomes, enhancing the model's overall effectiveness.
# 3. Comparing different models: Utilizing XGBoost to address correlated features (tree-based model) and imbalanced data, with focused model tuning for enhanced performance.
library(xgboost)##
## Attaching package: 'xgboost'## The following object is masked from 'package:dplyr':
##
## sliceset.seed(123)
# Define predictor names as a character vector
predictors <- c("rebounds_diff", "turnovers_diff", "possessions_diff", "ORTG_diff", "DRTG_diff", "NET_RTG_diff",
"TOV_percentage_diff", "eFG_diff", "last_15_points_diff", "last_15_rebounds_diff", "last_15_turnovers_diff",
"last_15_possessions_diff", "last_15_ORTG_diff", "last_15_DRTG_diff", "last_15_NET_RTG_diff",
"last_15_TOV_percentage_diff", "last_15_eFG_diff")
# Prepare training and testing data for xgboost
dtrain <- xgb.DMatrix(data = as.matrix(train_data[,predictors]), label = train_data$home_win)
dtest <- xgb.DMatrix(data = as.matrix(test_data[,predictors]), label = test_data$home_win)
# Calculate the ratio of negative to positive instances
scale_pos_weight <- sum(train_data$winner_label == "VisitorWin") / sum(train_data$winner_label == "HomeWin")
# Set parameters for xgboost
params <- list(
booster = "gbtree",
objective = "binary:logistic",
eta = 0.05,
gamma = 1,
max_depth = 5,
min_child_weight = 1,
subsample = 0.8,
colsample_bytree = 0.8,
eval_metric = "logloss",
scale_pos_weight = scale_pos_weight
)
# Run k-fold cross-validation
cv_results <- xgb.cv(
params = params,
data = dtrain,
nrounds = 100,
nfold = 5,
showsd = TRUE,
stratified = TRUE,
print_every_n = 10,
early_stopping_rounds = 10,
maximize = FALSE
)## [1] train-logloss:0.680309+0.000998 test-logloss:0.685212+0.004388
## Multiple eval metrics are present. Will use test_logloss for early stopping.
## Will train until test_logloss hasn't improved in 10 rounds.
##
## [11] train-logloss:0.573153+0.007551 test-logloss:0.653216+0.034496
## [21] train-logloss:0.503240+0.005059 test-logloss:0.631765+0.060502
## [31] train-logloss:0.451793+0.010155 test-logloss:0.621126+0.066304
## [41] train-logloss:0.417695+0.012407 test-logloss:0.615019+0.080863
## [51] train-logloss:0.386904+0.012732 test-logloss:0.608645+0.087619
## [61] train-logloss:0.364235+0.012298 test-logloss:0.600998+0.088091
## Stopping. Best iteration:
## [60] train-logloss:0.364418+0.012157 test-logloss:0.600313+0.087963# Getting the best number of rounds from cross-validation
best_nrounds <- cv_results$best_iteration
print(paste("Best number of trees (nrounds):", best_nrounds))## [1] "Best number of trees (nrounds): 60"# Training the final model using the best number of rounds
final_model <- xgb.train(
params = params,
data = dtrain,
nrounds = best_nrounds, # Use the best iteration count from CV
watchlist = list(train = dtrain, test = dtest)
)## [1] train-logloss:0.676363 test-logloss:0.679022
## [2] train-logloss:0.661358 test-logloss:0.667381
## [3] train-logloss:0.651975 test-logloss:0.664285
## [4] train-logloss:0.640534 test-logloss:0.654622
## [5] train-logloss:0.631889 test-logloss:0.657410
## [6] train-logloss:0.621068 test-logloss:0.652993
## [7] train-logloss:0.613163 test-logloss:0.652275
## [8] train-logloss:0.602928 test-logloss:0.645732
## [9] train-logloss:0.594489 test-logloss:0.641579
## [10] train-logloss:0.588803 test-logloss:0.641001
## [11] train-logloss:0.584425 test-logloss:0.641015
## [12] train-logloss:0.573374 test-logloss:0.629624
## [13] train-logloss:0.567446 test-logloss:0.625902
## [14] train-logloss:0.557888 test-logloss:0.622286
## [15] train-logloss:0.547207 test-logloss:0.619291
## [16] train-logloss:0.541182 test-logloss:0.614536
## [17] train-logloss:0.533067 test-logloss:0.611007
## [18] train-logloss:0.525209 test-logloss:0.603855
## [19] train-logloss:0.516745 test-logloss:0.601289
## [20] train-logloss:0.512001 test-logloss:0.595983
## [21] train-logloss:0.502249 test-logloss:0.591887
## [22] train-logloss:0.495804 test-logloss:0.588893
## [23] train-logloss:0.489880 test-logloss:0.589036
## [24] train-logloss:0.482192 test-logloss:0.587827
## [25] train-logloss:0.476609 test-logloss:0.581476
## [26] train-logloss:0.471926 test-logloss:0.576260
## [27] train-logloss:0.465731 test-logloss:0.574112
## [28] train-logloss:0.464132 test-logloss:0.574067
## [29] train-logloss:0.456627 test-logloss:0.571765
## [30] train-logloss:0.451449 test-logloss:0.571715
## [31] train-logloss:0.447608 test-logloss:0.570132
## [32] train-logloss:0.443735 test-logloss:0.566026
## [33] train-logloss:0.439110 test-logloss:0.563872
## [34] train-logloss:0.434756 test-logloss:0.564277
## [35] train-logloss:0.433064 test-logloss:0.562912
## [36] train-logloss:0.430950 test-logloss:0.560884
## [37] train-logloss:0.428204 test-logloss:0.560683
## [38] train-logloss:0.423809 test-logloss:0.557795
## [39] train-logloss:0.421286 test-logloss:0.557841
## [40] train-logloss:0.418839 test-logloss:0.558966
## [41] train-logloss:0.417489 test-logloss:0.560170
## [42] train-logloss:0.414606 test-logloss:0.558891
## [43] train-logloss:0.410769 test-logloss:0.552550
## [44] train-logloss:0.408227 test-logloss:0.550421
## [45] train-logloss:0.406321 test-logloss:0.547795
## [46] train-logloss:0.402546 test-logloss:0.543687
## [47] train-logloss:0.398147 test-logloss:0.541939
## [48] train-logloss:0.393595 test-logloss:0.540612
## [49] train-logloss:0.389233 test-logloss:0.542421
## [50] train-logloss:0.386834 test-logloss:0.541591
## [51] train-logloss:0.384266 test-logloss:0.538836
## [52] train-logloss:0.382264 test-logloss:0.541931
## [53] train-logloss:0.382684 test-logloss:0.544338
## [54] train-logloss:0.379010 test-logloss:0.546533
## [55] train-logloss:0.375452 test-logloss:0.542758
## [56] train-logloss:0.372941 test-logloss:0.540352
## [57] train-logloss:0.371933 test-logloss:0.539665
## [58] train-logloss:0.367178 test-logloss:0.538359
## [59] train-logloss:0.366125 test-logloss:0.537716
## [60] train-logloss:0.361709 test-logloss:0.538897# Predict on the test dataset using the best iteration
final_pred_probs <- predict(final_model, dtest)
final_pred_labels <- ifelse(final_pred_probs > 0.5, 1, 0)
# Convert the predictions to factor for confusion matrix
final_pred_labels <- factor(final_pred_labels, levels = c(0, 1))
actual_labels <- factor(test_data$home_win, levels = c(0, 1))
# Calculate the confusion matrix to evaluate the model
final_conf_matrix <- confusionMatrix(final_pred_labels, actual_labels)
print(final_conf_matrix)## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 5 8
## 1 3 17
##
## Accuracy : 0.6667
## 95% CI : (0.4817, 0.8204)
## No Information Rate : 0.7576
## P-Value [Acc > NIR] : 0.9185
##
## Kappa : 0.2515
##
## Mcnemar's Test P-Value : 0.2278
##
## Sensitivity : 0.6250
## Specificity : 0.6800
## Pos Pred Value : 0.3846
## Neg Pred Value : 0.8500
## Prevalence : 0.2424
## Detection Rate : 0.1515
## Detection Prevalence : 0.3939
## Balanced Accuracy : 0.6525
##
## 'Positive' Class : 0
## # Extract and print model performance metrics
accuracy <- final_conf_matrix$overall['Accuracy']
precision <- final_conf_matrix$byClass['Precision']
recall <- final_conf_matrix$byClass['Recall']
f1_score <- 2 * (precision * recall) / (precision + recall)
# Print performance metrics
print(paste("Accuracy:", accuracy))## [1] "Accuracy: 0.666666666666667"print(paste("Precision:", precision))## [1] "Precision: 0.384615384615385"print(paste("Recall:", recall))## [1] "Recall: 0.625"print(paste("F1 Score:", f1_score))## [1] "F1 Score: 0.476190476190476"# By trying to tune models, the XGBoost model still seems to be worse than logistic regression.
# One possible reason is overfitting due to the limited size of the training data (100 rows) and testing data (30 rows).
# With just a small dataset, XGBoost might struggle to generalize well to unseen data, leading to lower accuracy and less reliable predictions.
# 4. Using trained model to predict 2024 NBA playoffs first round.
# Corrected team names for playoff matchups
playoff_teams <- c("Boston Celtics", "Miami Heat", "New York Knicks", "Philadelphia 76ers",
"Milwaukee Bucks", "Indiana Pacers", "Cleveland Cavaliers", "Orlando Magic",
"Oklahoma City Thunder", "New Orleans Pelicans", "Denver Nuggets",
"Los Angeles Lakers", "Minnesota Timberwolves", "Phoenix Suns",
"LA Clippers", "Dallas Mavericks")
# Filtering for the 2023 season for these teams in both data frames
playoff_stats <- team_regular_season_stats %>%
filter(season == 2023, off_team_name %in% playoff_teams)
playoff_last_15_stats <- team_last_15_games_stats %>%
filter(season == 2023, off_team_name %in% playoff_teams)
# Join the regular season and last 15 games stats
playoff_data <- playoff_stats %>%
left_join(playoff_last_15_stats, by = c("season", "off_team_name"), suffix = c("", "_last_15"))
# Define the matchups
matchups <- data.frame(
home_team = c("Boston Celtics", "New York Knicks", "Milwaukee Bucks", "Cleveland Cavaliers",
"Oklahoma City Thunder", "Denver Nuggets", "Minnesota Timberwolves", "LA Clippers"),
visitor_team = c("Miami Heat", "Philadelphia 76ers", "Indiana Pacers", "Orlando Magic",
"New Orleans Pelicans", "Los Angeles Lakers", "Phoenix Suns", "Dallas Mavericks")
)
# Prepare matchup data for prediction
matchup_data <- matchups %>%
left_join(playoff_data, by = c("home_team" = "off_team_name")) %>%
left_join(playoff_data, by = c("visitor_team" = "off_team_name"), suffix = c("_home", "_visitor"))
# # Prepare data for XGBoost prediction
# predictors <- c("points_diff", "rebounds_diff", "turnovers_diff", "possessions_diff", "ORTG_diff", "DRTG_diff", "NET_RTG_diff",
# "last_15_points_diff", "last_15_rebounds_diff", "last_15_turnovers_diff", "last_15_possessions_diff", "last_15_ORTG_diff", "last_15_DRTG_diff", "last_15_NET_RTG_diff")
# Assuming you need to calculate differences or aggregate statistics:
matchup_data$points_diff <- matchup_data$avg_points_home - matchup_data$avg_points_visitor
matchup_data$rebounds_diff <- matchup_data$avg_rebounds_home - matchup_data$avg_rebounds_visitor
matchup_data$turnovers_diff <- matchup_data$turnovers_per_game_home - matchup_data$turnovers_per_game_visitor
matchup_data$possessions_diff <- matchup_data$possessions_per_game_home - matchup_data$possessions_per_game_visitor
matchup_data$ORTG_diff <- matchup_data$ORTG_home - matchup_data$ORTG_visitor
matchup_data$DRTG_diff <- matchup_data$DRTG_home - matchup_data$DRTG_visitor
matchup_data$NET_RTG_diff <- matchup_data$NET_RTG_home - matchup_data$NET_RTG_visitor
matchup_data$TOV_percentage_diff <- matchup_data$TOV_percentage_home - matchup_data$TOV_percentage_visitor
matchup_data$eFG_diff <- matchup_data$eFG_home - matchup_data$eFG_visitor
matchup_data$last_15_points_diff <- matchup_data$last_15_avg_points_home - matchup_data$last_15_avg_points_visitor
matchup_data$last_15_rebounds_diff <- matchup_data$last_15_avg_rebounds_home - matchup_data$last_15_avg_rebounds_visitor
matchup_data$last_15_turnovers_diff <- matchup_data$last_15_turnovers_per_game_home - matchup_data$last_15_turnovers_per_game_visitor
matchup_data$last_15_possessions_diff <- matchup_data$last_15_possessions_per_game_home - matchup_data$last_15_possessions_per_game_visitor
matchup_data$last_15_ORTG_diff <- matchup_data$last_15_ORTG_home - matchup_data$last_15_ORTG_visitor
matchup_data$last_15_DRTG_diff <- matchup_data$last_15_DRTG_home - matchup_data$last_15_DRTG_visitor
matchup_data$last_15_NET_RTG_diff <- matchup_data$last_15_NET_RTG_home - matchup_data$last_15_NET_RTG_visitor
matchup_data$last_15_TOV_percentage_diff <- matchup_data$last_15_TOV_percentage_home - matchup_data$last_15_TOV_percentage_visitor
matchup_data$last_15_eFG_diff <- matchup_data$last_15_eFG_home - matchup_data$last_15_eFG_visitor
# Prepare the DMatrix for prediction
dmatchup <- xgb.DMatrix(data = as.matrix(matchup_data[, predictors]))
# Now proceed with the prediction
matchup_xgb_predictions <- predict(final_model, dmatchup)
# Show the predictions
matchup_xgb_predictions## [1] 0.7541716 0.7692791 0.4077509 0.7964345 0.6596506 0.2167899 0.2146679
## [8] 0.5587957# Now proceed with the prediction using the logistic regression model
matchup_logistic_predictions <- predict(updated_model, newdata = matchup_data, type = "prob")
# Show the logistic regression predictions
matchup_logistic_predictions## VisitorWin HomeWin
## 1 0.05692148 0.9430785
## 2 0.14102330 0.8589767
## 3 0.52004187 0.4799581
## 4 0.39194365 0.6080563
## 5 0.19548697 0.8045130
## 6 0.31858515 0.6814149
## 7 0.53292775 0.4670723
## 8 0.09814264 0.9018574# Predicting game lengths for playoff series
# Additional DMatrix for the series length model
dtrain_games <- xgb.DMatrix(data = as.matrix(train_data[, predictors]), label = train_data$total_games)
dtest_games <- xgb.DMatrix(data = as.matrix(test_data[, predictors]), label = test_data$total_games)
params_games <- list(
booster = "gbtree",
objective = "reg:squarederror",
eta = 0.1,
max_depth = 6,
min_child_weight = 1,
subsample = 0.8,
colsample_bytree = 0.8
)
games_model <- xgb.train(params = params_games, data = dtrain_games, nrounds = 100, watchlist = list(train = dtrain_games, eval = dtest_games), early_stopping_rounds = 10)## [1] train-rmse:4.585483 eval-rmse:4.949461
## Multiple eval metrics are present. Will use eval_rmse for early stopping.
## Will train until eval_rmse hasn't improved in 10 rounds.
##
## [2] train-rmse:4.151199 eval-rmse:4.518904
## [3] train-rmse:3.764593 eval-rmse:4.136104
## [4] train-rmse:3.428146 eval-rmse:3.809131
## [5] train-rmse:3.113388 eval-rmse:3.505577
## [6] train-rmse:2.831438 eval-rmse:3.229500
## [7] train-rmse:2.587432 eval-rmse:2.983374
## [8] train-rmse:2.364990 eval-rmse:2.770764
## [9] train-rmse:2.172405 eval-rmse:2.587485
## [10] train-rmse:2.002028 eval-rmse:2.447696
## [11] train-rmse:1.840422 eval-rmse:2.289332
## [12] train-rmse:1.703128 eval-rmse:2.175609
## [13] train-rmse:1.563352 eval-rmse:2.075789
## [14] train-rmse:1.442350 eval-rmse:1.998481
## [15] train-rmse:1.328738 eval-rmse:1.934216
## [16] train-rmse:1.227936 eval-rmse:1.857811
## [17] train-rmse:1.129222 eval-rmse:1.801090
## [18] train-rmse:1.045679 eval-rmse:1.742725
## [19] train-rmse:0.969065 eval-rmse:1.686284
## [20] train-rmse:0.902315 eval-rmse:1.642533
## [21] train-rmse:0.845601 eval-rmse:1.606539
## [22] train-rmse:0.786827 eval-rmse:1.569745
## [23] train-rmse:0.737135 eval-rmse:1.537651
## [24] train-rmse:0.690830 eval-rmse:1.500171
## [25] train-rmse:0.644690 eval-rmse:1.464368
## [26] train-rmse:0.601835 eval-rmse:1.449753
## [27] train-rmse:0.561886 eval-rmse:1.433725
## [28] train-rmse:0.528250 eval-rmse:1.414752
## [29] train-rmse:0.497230 eval-rmse:1.401268
## [30] train-rmse:0.464507 eval-rmse:1.382268
## [31] train-rmse:0.437968 eval-rmse:1.375037
## [32] train-rmse:0.408791 eval-rmse:1.369938
## [33] train-rmse:0.385874 eval-rmse:1.360216
## [34] train-rmse:0.365106 eval-rmse:1.353203
## [35] train-rmse:0.343817 eval-rmse:1.347507
## [36] train-rmse:0.323625 eval-rmse:1.343761
## [37] train-rmse:0.305767 eval-rmse:1.333894
## [38] train-rmse:0.287194 eval-rmse:1.329922
## [39] train-rmse:0.271638 eval-rmse:1.330583
## [40] train-rmse:0.257982 eval-rmse:1.321602
## [41] train-rmse:0.245007 eval-rmse:1.317172
## [42] train-rmse:0.231094 eval-rmse:1.314924
## [43] train-rmse:0.218781 eval-rmse:1.312867
## [44] train-rmse:0.206579 eval-rmse:1.308979
## [45] train-rmse:0.196194 eval-rmse:1.301049
## [46] train-rmse:0.187017 eval-rmse:1.295711
## [47] train-rmse:0.177805 eval-rmse:1.292565
## [48] train-rmse:0.165456 eval-rmse:1.295117
## [49] train-rmse:0.156973 eval-rmse:1.293527
## [50] train-rmse:0.149561 eval-rmse:1.291280
## [51] train-rmse:0.141185 eval-rmse:1.290880
## [52] train-rmse:0.133806 eval-rmse:1.289227
## [53] train-rmse:0.128152 eval-rmse:1.289007
## [54] train-rmse:0.122408 eval-rmse:1.287495
## [55] train-rmse:0.118050 eval-rmse:1.287202
## [56] train-rmse:0.113187 eval-rmse:1.285889
## [57] train-rmse:0.108695 eval-rmse:1.285414
## [58] train-rmse:0.103937 eval-rmse:1.284429
## [59] train-rmse:0.099813 eval-rmse:1.282953
## [60] train-rmse:0.096961 eval-rmse:1.281673
## [61] train-rmse:0.092772 eval-rmse:1.281479
## [62] train-rmse:0.089370 eval-rmse:1.283083
## [63] train-rmse:0.085225 eval-rmse:1.282346
## [64] train-rmse:0.080520 eval-rmse:1.281297
## [65] train-rmse:0.077044 eval-rmse:1.279100
## [66] train-rmse:0.073623 eval-rmse:1.279383
## [67] train-rmse:0.069900 eval-rmse:1.279470
## [68] train-rmse:0.068140 eval-rmse:1.279110
## [69] train-rmse:0.066027 eval-rmse:1.279457
## [70] train-rmse:0.063445 eval-rmse:1.279304
## [71] train-rmse:0.060993 eval-rmse:1.278734
## [72] train-rmse:0.059200 eval-rmse:1.278638
## [73] train-rmse:0.057513 eval-rmse:1.278608
## [74] train-rmse:0.055292 eval-rmse:1.278312
## [75] train-rmse:0.052981 eval-rmse:1.279735
## [76] train-rmse:0.051192 eval-rmse:1.280749
## [77] train-rmse:0.049681 eval-rmse:1.280982
## [78] train-rmse:0.048852 eval-rmse:1.280739
## [79] train-rmse:0.047216 eval-rmse:1.280278
## [80] train-rmse:0.044970 eval-rmse:1.279904
## [81] train-rmse:0.043181 eval-rmse:1.278901
## [82] train-rmse:0.041342 eval-rmse:1.278594
## [83] train-rmse:0.039582 eval-rmse:1.278209
## [84] train-rmse:0.038278 eval-rmse:1.278030
## [85] train-rmse:0.037166 eval-rmse:1.278544
## [86] train-rmse:0.035644 eval-rmse:1.278610
## [87] train-rmse:0.034658 eval-rmse:1.278784
## [88] train-rmse:0.032721 eval-rmse:1.278090
## [89] train-rmse:0.031645 eval-rmse:1.277602
## [90] train-rmse:0.030341 eval-rmse:1.277390
## [91] train-rmse:0.029169 eval-rmse:1.277794
## [92] train-rmse:0.028224 eval-rmse:1.277522
## [93] train-rmse:0.027478 eval-rmse:1.277525
## [94] train-rmse:0.026630 eval-rmse:1.277792
## [95] train-rmse:0.025553 eval-rmse:1.276982
## [96] train-rmse:0.024776 eval-rmse:1.276956
## [97] train-rmse:0.024335 eval-rmse:1.276625
## [98] train-rmse:0.023446 eval-rmse:1.276998
## [99] train-rmse:0.022484 eval-rmse:1.277134
## [100] train-rmse:0.021941 eval-rmse:1.277585# Predicting the number of games for the test dataset
predicted_games <- predict(games_model, dtest_games)
# Evaluate the predictions by comparing them to the actual number of games
actual_games <- test_data$total_games # Ensure you have this column in your test_data
# Calculate RMSE (Root Mean Squared Error) to evaluate prediction accuracy
rmse <- sqrt(mean((predicted_games - actual_games)^2))
print(paste("RMSE for games predictions:", rmse))## [1] "RMSE for games predictions: 1.27662481450771"# Optionally, plot the predictions against the actual to visualize performance
plot(actual_games, predicted_games, main = "Predicted vs. Actual Number of Games",
xlab = "Actual Number of Games", ylab = "Predicted Number of Games", pch = 19)
abline(0, 1, col = "red")
# Prepare the DMatrix for the 2024 playoff matchups
dmatchup_2024 <- xgb.DMatrix(data = as.matrix(matchup_data[, predictors]))
# Predict the number of games for each matchup
matchup_games_predictions <- predict(games_model, dmatchup_2024)
# Create a dataframe to hold the predictions with team names for visualization
matchup_predictions_df <- data.frame(
HomeTeam = matchups$home_team,
VisitorTeam = matchups$visitor_team,
PredictedGames = round(matchup_games_predictions)
)
# Using ggplot2 to visualize the predictions
library(ggplot2)
ggplot(matchup_predictions_df, aes(x = HomeTeam, y = PredictedGames, fill = HomeTeam)) +
geom_bar(stat = "identity", position = position_dodge()) +
theme_minimal() +
labs(title = "Predicted Number of Games in 2024 NBA Playoffs First Round",
x = "Home Team", y = "Predicted Number of Games") +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
# Using regression to predict game length
# Additional DMatrix for the series length model
train_control_games <- trainControl(method = "cv", number = 10, savePredictions = "final")
# Define the model formula
formula_games <- total_games ~ points_diff + rebounds_diff + turnovers_diff + possessions_diff + ORTG_diff + NET_RTG_diff + eFG_diff
# Training the model using linear regression
games_model_regression <- train(formula_games, data = train_data, method = "lm", trControl = train_control_games)
# Predicting the number of games for the test dataset
predicted_games_regression <- predict(games_model_regression, newdata = test_data)
# Evaluate the predictions by comparing them to the actual number of games
actual_games <- test_data$total_games # Ensure you have this column in your test_data
# Calculate RMSE (Root Mean Squared Error) to evaluate prediction accuracy
rmse_regression <- sqrt(mean((predicted_games_regression - actual_games)^2))
print(paste("RMSE for games predictions using linear regression:", rmse_regression))## [1] "RMSE for games predictions using linear regression: 1.11844056810399"# Optionally, plot the predictions against the actual to visualize performance
plot(actual_games, predicted_games_regression, main = "Predicted vs. Actual Number of Games (Linear Regression)",
xlab = "Actual Number of Games", ylab = "Predicted Number of Games", pch = 19)
abline(0, 1, col = "red")
# Predict the number of games for each matchup
matchup_games_predictions_regression <- predict(games_model_regression, newdata = matchup_data)
# Create a dataframe to hold the predictions with team names for visualization
matchup_predictions_df_regression <- data.frame(
HomeTeam = matchups$home_team,
VisitorTeam = matchups$visitor_team,
PredictedGames = round(matchup_games_predictions_regression)
)
# Using ggplot2 to visualize the predictions
library(ggplot2)
ggplot(matchup_predictions_df_regression, aes(x = HomeTeam, y = PredictedGames, fill = HomeTeam)) +
geom_bar(stat = "identity", position = position_dodge()) +
theme_minimal() +
labs(title = "Predicted Number of Games in 2024 NBA Playoffs First Round (Regression Model)",
x = "Home Team", y = "Predicted Number of Games") +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
library(ggplot2)
library(dplyr)
library(tidyr)
combined_data <- data.frame(
HomeTeam = matchups$home_team,
VisitorTeam = matchups$visitor_team,
HomeWinProb_Logistic = matchup_logistic_predictions[, "HomeWin"],
VisitorWinProb_Logistic = 1 - matchup_logistic_predictions[, "HomeWin"],
HomeWinProb_XGB = matchup_xgb_predictions,
VisitorWinProb_XGB = 1 - matchup_xgb_predictions,
PredictedGames_XGB = round(matchup_games_predictions),
PredictedGames_LM = round(matchup_games_predictions_regression)
)
#
# # Assuming visualization_data is already initialized with correct values
# visualization_data <- data.frame(
# HomeTeam = matchups$home_team,
# VisitorTeam = matchups$visitor_team,
# HomeWinProb_Logistic = matchup_logistic_predictions[, "HomeWin"],
# VisitorWinProb_Logistic = 1 - matchup_logistic_predictions[, "HomeWin"],
# HomeWinProb_XGB = matchup_xgb_predictions,
# VisitorWinProb_XGB = 1 - matchup_xgb_predictions
# )
#
# # Adding the matchup description
# visualization_data$Matchup <- paste(visualization_data$HomeTeam, "vs", visualization_data$VisitorTeam)
#
# # Reshape the data to a suitable format for plotting
# visualization_long <- visualization_data %>%
# pivot_longer(
# cols = starts_with("HomeWinProb") | starts_with("VisitorWinProb"),
# names_to = "Model_Team",
# values_to = "Probability"
# ) %>%
# mutate(
# Model = ifelse(grepl("XGB", Model_Team), "XGB", "Logistic"),
# Side = ifelse(grepl("Home", Model_Team), "Home", "Visitor"),
# Team = ifelse(Side == "Home", HomeTeam, VisitorTeam)
# )
#
# # Create the ggplot
# plot <- ggplot(visualization_long, aes(x = Matchup, y = Probability, fill = Side)) +
# geom_bar(stat = "identity", position = "fill") + # Use position = "fill" to scale bars to the same length
# facet_wrap(~ Model, scales = "free_x") + # Separate plots for each model
# scale_fill_manual(values = c("Home" = "dodgerblue3", "Visitor" = "coral")) +
# labs(title = "2024 NBA Playoffs First Round Predictions",
# y = "Win Probability", x = "") +
# theme_minimal() +
# theme(axis.text.x = element_text(angle = 45, hjust = 1),
# axis.title.x = element_blank(),
# legend.position = "bottom")
#
# # Display the plot
# print(plot)Part 3 – Finding Insights from Your Model
Find two teams that had a competitive window of 2 or more consecutive seasons making the playoffs and that under performed your model’s expectations for them, losing series they were expected to win. Why do you think that happened? Classify one of them as bad luck and one of them as relating to a cause not currently accounted for in your model. If given more time and data, how would you use what you found to improve your model?
ANSWER :