En la previa de un partido de tenis importante para nuestro tenista favorito, o también en la de un partido de fútbol del equipo del cual somos hinchas, uno puede preguntarse: ¿cuáles son las chances de obtener una victoria? Para intentar responder esta pregunta, los métodos y algoritmos de la ciencia de datos nos pueden ser de gran ayuda.
En este trabajo se aplicará la técnica de regresión logística para intentar, en primer lugar, identificar variables que puedan explicar el resultado de un partido de tenis y, en segundo lugar, utilizar esas mismas variables (u otras) para predecir el resultado del mismo.
No ahondaremos en la descripción detallada del modelo de regresión logística, ya que existe una gran cantidad de información acerca del mismo. Solo diremos que se trata de un modelo paramétrico, un caso particular de Modelo Lineal Generalizado (GLM), y que estos últimos vienen a generalizar a los modelos de regresión lineal tradicionales que todos conocemos. En síntesis, es un modelo lineal adaptado para intentar resolver un problema de clasificación binaria, como puede ser el problema de modelar el resultado de un partido de tenis que tiene solo dos resultados posibles desde la óptica de nuestro jugador favorito: victoria o derrota.
Para encarar el problema de predecir el resultado en un partido de tenis, parece intuitivo seleccionar un único jugador y buscar el mejor modelo para ese tenista. Puede que algunas variables sean más o menos importantes para cada uno de los diferentes jugadores en el circuito, con lo cual esta forma de encarar el problema parece ser apropiada.
En este primer approach se modelará el resultado de un partido de tenis de Rafael Nadal, tenista con amplia trayectoria en el circuito y con un caudal de partidos que le otorga robustez a los análisis que se realizarán.
En las próximas secciones iremos desarrollando, paso a paso, la aplicación de modelos de regresión logística en nuestro problema de clasificación. Todo el trabajo ha sido realizado usando R como herramienta principal.
Arrancamos con un setup del environment donde vamos a trabajar.
#Cargo librerías de interés
pacman::p_load(pacman, tidyverse, rio, magrittr, lubridate,
boot, caret, e1071, readr, correlation, see, ggraph,
RColorBrewer, ggthemes, psych)
options(scipen = 999) #Elimino notación científica
Importamos la base de datos con la que trabajaremos. La misma fue confeccionada a partir de los registros históricos de partidos correspondientes al ATP Men’s Tour, publicado por el sitio http://www.tennis-data.co.uk/, a quien agradecemos infinitamente por el aporte.
#importo base desde repositorio en github
path <- "https://raw.githubusercontent.com/tomasroel/ProyectoKickRepo/main/Output/matches_nadal_ok.csv"
matches_nadal_ok <- read_csv(url(path))[,-1]
#separo las variables a utilizar
variables <- c("Location", "Series", "Court", "Surface", "Date",
"Round", "BestOf", "RankNadal", "RankRival",
"PartidosUlt6Meses", "PartidosUlt3Meses", "PartidosUltMes",
"WRUlt6Meses", "WRUlt3Meses", "WRUltMes",
"PartidosRivalUlt6Meses", "PartidosRivalUlt3Meses",
"PartidosRivalUltMes", "WRRivalUlt6Meses", "WRRivalUlt3Meses",
"WRRivalUltMes", "SetsGanadosUltPartido", "SetsPerdidosUltPartido",
"ResultUltPartido", "RoundUltPartido", "H2HPartidos", "H2HGanados",
"Result")
#Ajusto data types de variables
df_matches <- matches_nadal_ok %>%
select(all_of(variables)) %>%
mutate_at(vars(Location, Series, Court, Surface,
Round, BestOf, ResultUltPartido, RoundUltPartido, Result),
as.factor)
glimpse(df_matches) #Vistazo a la base
## Rows: 1,129
## Columns: 28
## $ Location <fct> Doha, Doha, Doha, Auckland, Melbourne, Melbourn~
## $ Series <fct> International, International, International, In~
## $ Court <fct> Outdoor, Outdoor, Outdoor, Outdoor, Outdoor, Ou~
## $ Surface <fct> Hard, Hard, Hard, Hard, Hard, Hard, Hard, Hard,~
## $ Date <date> 2005-01-04, 2005-01-05, 2005-01-06, 2005-01-11~
## $ Round <fct> 1st Round, 2nd Round, Quarterfinals, 1st Round,~
## $ BestOf <fct> 3, 3, 3, 3, 5, 5, 5, 5, 3, 3, 3, 3, 3, 3, 3, 3,~
## $ RankNadal <dbl> 51, 51, 51, 50, 56, 56, 56, 56, 48, 48, 48, 48,~
## $ RankRival <dbl> 16, 36, 22, 20, 65, 15, 283, 3, 61, 66, 8, 55, ~
## $ PartidosUlt6Meses <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 14, ~
## $ PartidosUlt3Meses <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 14, ~
## $ PartidosUltMes <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 6, 6, 7, 8, 9, 9, 9, 10~
## $ WRUlt6Meses <dbl> 1.0000000, 1.0000000, 0.6666667, 0.5000000, 0.6~
## $ WRUlt3Meses <dbl> 1.0000000, 1.0000000, 0.6666667, 0.5000000, 0.6~
## $ WRUltMes <dbl> 1.0000000, 1.0000000, 0.6666667, 0.5000000, 0.6~
## $ PartidosRivalUlt6Meses <dbl> 1, 2, 3, 1, 4, 3, 3, 12, 9, 8, 13, 12, 5, 12, 1~
## $ PartidosRivalUlt3Meses <dbl> 1, 2, 3, 1, 4, 3, 3, 12, 9, 8, 13, 12, 5, 12, 1~
## $ PartidosRivalUltMes <dbl> 1, 2, 3, 1, 4, 3, 3, 12, 7, 6, 12, 9, 4, 8, 6, ~
## $ WRRivalUlt6Meses <dbl> 0.0000000, 0.5000000, 1.0000000, 1.0000000, 0.2~
## $ WRRivalUlt3Meses <dbl> 0.0000000, 0.5000000, 1.0000000, 1.0000000, 0.2~
## $ WRRivalUltMes <dbl> 0.0000000, 0.5000000, 1.0000000, 1.0000000, 0.2~
## $ SetsGanadosUltPartido <dbl> 0, 2, 2, 1, 0, 3, 3, 3, 2, 2, 2, 1, 2, 2, 2, 2,~
## $ SetsPerdidosUltPartido <dbl> 0, 0, 0, 2, 1, 0, 2, 0, 3, 0, 0, 2, 0, 0, 1, 1,~
## $ ResultUltPartido <fct> NA, Win, Win, Lose, Lose, Win, Win, Win, Lose, ~
## $ RoundUltPartido <fct> NA, 1st Round, 2nd Round, Quarterfinals, 1st Ro~
## $ H2HPartidos <dbl> 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0,~
## $ H2HGanados <dbl> 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0,~
## $ Result <fct> Win, Win, Lose, Lose, Win, Win, Win, Lose, Win,~
Nuestra variable target será ‘Resultado’. Esta variable puede tomar solo dos valores, “win” o “lose”. El resto de las variables aportan información sobre el contexto en el cual se está jugando el partido (superficie, cantidad de sets a disputar, ronda, etc.) y también aportan información sobre la condición previa en que llega cada jugador al partido (ranking, cantidad de partidos jugados, porcentaje de partidos ganados, resultado del último partido, etc.).
Ahora, con la base cargada, hacemos unos ajustes necesarios previos al análisis.
#Elimino observaciones que no me sirven porque no tengo registro de los partidos anteriores
df_matches %>%
select(Location, RankNadal,
PartidosUlt6Meses, PartidosUlt3Meses, PartidosUltMes) %>%
print(n = 70)
## # A tibble: 1,129 x 5
## Location RankNadal PartidosUlt6Meses PartidosUlt3Meses PartidosUltMes
## <fct> <dbl> <dbl> <dbl> <dbl>
## 1 Doha 51 1 1 1
## 2 Doha 51 2 2 2
## 3 Doha 51 3 3 3
## 4 Auckland 50 4 4 4
## 5 Melbourne 56 5 5 5
## 6 Melbourne 56 6 6 6
## 7 Melbourne 56 7 7 7
## 8 Melbourne 56 8 8 8
## 9 Buenos Aires 48 9 9 6
## 10 Buenos Aires 48 10 10 6
## 11 Buenos Aires 48 11 11 7
## 12 Costa Do Sauipe 48 12 12 8
## 13 Costa Do Sauipe 48 14 14 9
## 14 Costa Do Sauipe 48 14 14 9
## 15 Costa Do Sauipe 48 15 15 9
## 16 Costa Do Sauipe 48 16 16 10
## 17 Acapulco 39 17 17 10
## 18 Acapulco 39 18 18 10
## 19 Acapulco 39 19 19 11
## 20 Acapulco 39 20 20 12
## 21 Acapulco 39 21 21 13
## 22 Miami 31 22 22 4
## 23 Miami 31 23 23 4
## 24 Miami 31 24 24 3
## 25 Miami 31 25 25 4
## 26 Miami 31 26 26 5
## 27 Miami 31 27 27 6
## 28 Valencia 17 28 25 7
## 29 Valencia 17 29 26 8
## 30 Valencia 17 30 27 9
## 31 Monte Carlo 17 31 27 10
## 32 Monte Carlo 17 32 28 11
## 33 Monte Carlo 17 33 29 12
## 34 Monte Carlo 17 34 30 13
## 35 Monte Carlo 17 35 31 14
## 36 Monte Carlo 17 36 32 15
## 37 Barcelona 11 37 31 16
## 38 Barcelona 11 38 32 17
## 39 Barcelona 11 39 32 18
## 40 Barcelona 11 40 33 19
## 41 Barcelona 11 41 33 19
## 42 Rome 7 42 34 15
## 43 Rome 7 43 35 16
## 44 Rome 7 44 36 17
## 45 Rome 7 45 37 17
## 46 Rome 7 46 38 17
## 47 Rome 7 47 39 17
## 48 Paris 5 48 31 8
## 49 Paris 5 49 31 8
## 50 Paris 5 50 30 9
## 51 Paris 5 51 30 10
## 52 Paris 5 52 31 11
## 53 Paris 5 53 32 10
## 54 Paris 5 54 33 9
## 55 Halle 3 55 34 8
## 56 London 3 56 35 9
## 57 London 3 57 35 9
## 58 Bastad 3 55 30 4
## 59 Bastad 3 56 29 5
## 60 Bastad 3 57 30 5
## 61 Bastad 3 58 31 6
## 62 Bastad 3 58 31 7
## 63 Stuttgart 3 57 25 8
## 64 Stuttgart 3 57 25 8
## 65 Stuttgart 3 58 25 9
## 66 Stuttgart 3 58 25 9
## 67 Stuttgart 3 59 26 10
## 68 Montreal 2 58 21 6
## 69 Montreal 2 59 23 8
## 70 Montreal 2 59 23 8
## # ... with 1,059 more rows
#Elimino primeras 50 observaciones, a partir de ahí se nivela
df_matches <- df_matches[51:nrow(df_matches),]
Vamos a echar un vistazo a los datos con los que vamos a trabajar mirando unos plots rápidos. La idea es ver cómo varía el porcentaje de victorias de Rafael Nadal en el circuito cuando segmentamos los partidos por alguna de las variables que tenemos disponibles.
#Arranco mirando resultado según el rendimiento que tuvo en los últimos 6 meses.
df_matches %>%
ggplot(aes(x = PartidosUlt6Meses, y = WRUlt6Meses,
color = Result)) +
geom_jitter(width = 1.5) +
scale_color_brewer(palette = "Set1") +
labs(x = "Partidos Nadal Últimos 6 Meses",
y = "Win Rate Nadal Últimos 6 Meses") +
theme_few()
#Miramos ahora la relación entre rankings y resultado del partido
df_matches %>%
ggplot(aes(x = RankNadal, y = RankRival,
color = Result)) +
geom_jitter() +
coord_cartesian(ylim = c(0, 20),
xlim = c(0, 10)) +
scale_x_continuous(breaks = c(1,3,5,7,9)) +
scale_color_brewer(palette = "Set1") +
labs(x = "Ranking Nadal",
y = "Ranking Rival") +
theme_few()
#Superficie y resultado
df_matches %>%
ggplot(aes(x = Surface, fill = Result)) +
geom_bar(position = "fill") +
scale_fill_brewer(palette = "Set1") +
labs(x = "Surface") +
theme_few()
#Longitud del partido
df_matches %>%
ggplot(aes(x = BestOf, fill = Result)) +
geom_bar(position = "fill") +
facet_grid(.~Surface) +
scale_fill_brewer(palette = "Set1") +
labs(x = "Best Of") +
theme_few()
#Ronda y superficie
df_matches %>%
ggplot(aes(x = Round, fill = Result)) +
geom_bar(position = "fill") +
facet_grid(.~Surface) +
scale_fill_brewer(palette = "Set1") +
labs(x = "Round",
y = "Porcentaje de victorias") +
theme_few() +
theme(axis.text.x = element_text(angle = 45,
size = 6,
vjust = 1,
hjust = 1))
#Relación entre resultados de últimos 3 y 6 meses
df_matches %>%
ggplot(aes(x = PartidosUlt6Meses, y = PartidosUlt3Meses)) +
geom_jitter() +
scale_color_brewer(palette = "Set1") +
labs(x = "Partidos Nadal Últimos 6 Meses",
y = "Partidos Nadal Últimos 3 Meses") +
theme_few()
#Relación entre partidos de últimos 3 y 6 meses
df_matches %>%
ggplot(aes(x = PartidosUlt6Meses, y = PartidosUltMes)) +
geom_jitter() +
scale_color_brewer(palette = "Set1") +
labs(x = "Partidos Nadal Últimos 6 Meses",
y = "Partidos Nadal Último Mes") +
theme_few()
#Relación entre partidos del último mes 3 meses
df_matches %>%
ggplot(aes(x = PartidosUlt3Meses, y = PartidosUltMes)) +
geom_jitter() +
scale_color_brewer(palette = "Set1") +
labs(x = "Partidos Nadal Últimos 3 Meses",
y = "Partidos Nadal Último Mes") +
theme_few()
Obtenemos algunas conclusiones de estos gráficos:
Con esto, claramente, no descubrimos nada nuevo. La intención ahora es utilizar estas conclusiones para modelar la probabilidad de victoria en un partido de Nadal, y en base a ello poder predecir el resultado del partido.
Un punto sumamente importante a revisar previo al ajuste de modelos es el de las correlaciones parciales entre los variables que disponemos. Con la base de datos disponible, calculamos las correlaciones entre cada una de las variables y vemos qué conclusiones podemos sacar.
#Matriz de correlaciones en forma de lista y ordenada
correlation(df_matches[,c(3:4,6:28)] %>%
filter(!is.na(SetsPerdidosUltPartido) & !is.na(RoundUltPartido)),
include_factors = TRUE,
method = "auto") %>%
as_tibble() %>%
arrange(desc(r))
Las variables con una alta correlación (ya sea positiva o negativa) no deberían ser utilizadas de forma conjunta como predictoras en un modelo de regresión ya que afectan de forma negativa el resultado del mismo.
Analizando la tabla de correlaciones podemos sacar conclusiones que en principio pueden parecer triviales, como por ejemplo, que hay una alta correlación entre la variable ‘Round’ y la variable ‘RoundUltPartido’. También podemos obtener otras conclusiones más importantes, como por ejemplo que existe una alta correlación positiva ente el win rate de los últimos 6 y 3 meses, tanto para los rivales como para Nadal. Lo mismo pasa entre el win rate de los últimos 3 meses y el del último mes.
A la hora de elegir combinaciones de predictoras tendremos entonces que prestar atención a estos resultados e intentar combinar variables con poca correlación, como pueden ser la variable win rate del último mes con la variable win rate de los últimos 6 meses.
Vamos a utilizar un modelo logístico para predecir un resultado de un partido de tenis de Nadal. Ahora bien, cuando miremos los resultados de clasificación del modelo, ¿qué tasa de aciertos consideraremos como “buena”? Nadal, de por sí, gana la gran mayoría de partidos en los que participa, con lo cual una buena estrategia para “predecir” el resultado del partido parece ser decir que siempre va a ganar Nadal, sin tener en cuenta ninguna variable adicional.
Veamos cuál sería, estadísticamente, nuestra tasa de acierto si nos jugáramos siempre a que gana Nadal.
#Probabilidad histórica de victoria Nadal
tasa_historica <- df_matches %>%
pull(Result) %>%
table() %>%
prop.table()
tasa_historica
## .
## Lose Win
## 0.1603336 0.8396664
#Probabilidad a partir de 2019
tasa_2019 <- df_matches %>%
filter(Date > ymd("2019-01-01")) %>%
pull(Result) %>%
table() %>%
prop.table()
tasa_2019
## .
## Lose Win
## 0.1525424 0.8474576
#Probabilidad 2020 en adelante
tasa_2020 <- df_matches %>%
filter(Date > ymd("2020-01-01")) %>%
pull(Result) %>%
table() %>%
prop.table()
tasa_2020
## .
## Lose Win
## 0.1636364 0.8363636
#Probabilidad post cuarentena
tasa_postReceso <- df_matches %>%
filter(Date > ymd("2020-08-01")) %>%
pull(Result) %>%
table() %>%
prop.table()
tasa_postReceso
## .
## Lose Win
## 0.1777778 0.8222222
#Probabilidad 2021
tasa_post2021 <- df_matches %>%
filter(Date > ymd("2020-12-31")) %>%
pull(Result) %>%
table() %>%
prop.table()
tasa_post2021
## .
## Lose Win
## 0.1481481 0.8518519
#En clay 2019 en adelante
tasa_clay <- df_matches %>%
filter(Date > ymd("2018-12-31") &
Surface == "Clay") %>%
pull(Result) %>%
table() %>%
prop.table()
tasa_clay
## .
## Lose Win
## 0.125 0.875
Las tasas históricas de victoria de Rafael Nadal son las siguientes:
En base a estos números, podemos decir que un modelo predictivo, para que sea realmente útil, debería tener una tasa de acierto esperada superior al 90%. Un modelo que acierta el resultado en menos del 85% de los partidos no representa ninguna mejora respecto a la “estrategia” de predicción consistente en decir que siempre gana Nadal.
Ahora sí, ya con una primera impresión de cómo se ven los datos y cómo podrían afectar las covariables al resultado del partido, comenzamos a ajustar los modelos.
Como primer paso, vamos a ajustar un modelo con todas las covariables disponibles como predictoras. La función de linkeo con la que trabajaremos es la función ‘logit’.
Como estrategia de entrenamiento y testeo, entrenamos utilizando m-repeated k-fold cross validation para obtener una medida del error que no esté sesgada por los datos. Este entrenamiento se realizará solo con los partidos previos a abril 2020 (inicio de la pandemia COVID-19). Los partidos post receso por pandemia serán utilizados como base de testeo, donde se analizará de forma más precisa la performance predictiva del modelo.
En el primer modelo ajustado - modelo 0 - se utilizarán todos los features disponibles para modelar el resultado del partido. De este análisis se desprenderán indicios sobre cuáles covariables pueden tener una fuerte relación con el resultado del partido.
#Separo partidos post receso. Sera mi base test
df_matches_train <- df_matches %>%
filter(Date < "2020-04-01")
df_matches_test <- df_matches %>%
filter(Date >= "2020-04-01")
#Defino el trainControl, aplicable solo a este modelo.
trainControlfit0 <- trainControl(method = "cv", number = 10)
#Modelo 0 - prueba de covariables. No uso todas las variables, algunas no nos interesan
glm.fit0 <- train(Result ~ Court + Surface + Round + BestOf + RankNadal +
RankRival + PartidosUlt6Meses + PartidosUlt3Meses +
PartidosUltMes + WRUlt6Meses + WRUlt3Meses + WRUltMes +
PartidosRivalUlt6Meses + PartidosRivalUlt3Meses +
PartidosRivalUltMes + WRRivalUlt6Meses + WRRivalUlt3Meses +
WRRivalUltMes + SetsGanadosUltPartido +
SetsPerdidosUltPartido +ResultUltPartido + RoundUltPartido +
H2HPartidos + H2HGanados,
data = df_matches_train,
trControl = trainControlfit0,
method = "glm",
family = "binomial",
na.action = na.omit)
#Vemos el objeto que obtenemos
glm.fit0
## Generalized Linear Model
##
## 1034 samples
## 24 predictor
## 2 classes: 'Lose', 'Win'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold)
## Summary of sample sizes: 917, 918, 918, 917, 916, 917, ...
## Resampling results:
##
## Accuracy Kappa
## 0.9470573 0.7970867
#Armamos un gráfico para ver cuales son las variables más significativas en términos de p-valor
glm.fit0 %>%
summary() %>%
coef() %>%
as_tibble() %>%
cbind(Variable = glm.fit0 %>%
summary() %>%
coef() %>% rownames(),.) %>%
mutate(`Pr(>|z|)` = round(`Pr(>|z|)`, 6)) %>%
ggplot(aes(x = reorder(Variable, `Pr(>|z|)`), y = `Pr(>|z|)`)) +
geom_bar(stat = "identity", fill = brewer.pal(n = 5, "Set1")[2]) +
labs(x = "",
y = "P Value") +
theme_few() +
theme(axis.text.x = element_text(angle = 45,
size = 10,
vjust = 1,
hjust = 1))
Mirando los p-value de los coeficientes del modelo podemos ver que hay algunas variables que tienen un impacto significativo en el resultado del partido. Éstas son:
Estas variables parecen tener una importante capacidad para explicar el resultado del partido. Las variables más importantes parecen ser la cantidad de partidos jugados en el último mes y el porcentaje de victorias en éste. Éstas dos dan un indicio de cómo llega el jugador al partido, es decir si llega con ritmo y en racha. Otra variable importante parece ser la ronda a la que corresponde el partido, sobre todo si se trata de la final. Allí el modelo identifica que Nadal tiene altas chances de ganar. La cantidad de partidos jugados y el porcentaje de victorias del rival también parecen ser muy importantes, ya que indican en qué condiciones llega el rival al partido.
Ahora, ajustaremos una serie de modelos, buscando el de mejor performance predictiva. La selección de covariables a utilizar en cada ajuste estará basada en las conclusiones obtenidas del modelo 0. Para determinar cuál es el mejor modelo, compararemos la métrica de error obtenida del entrenamiento vía cross validation. También utilizaremos el dataset de testeo para valuar performance en éste. La tasa de corte para clasificar los partidos en “win” o “lose” será del 80%. Es decir, si la probabilidad de victoria predicha por el modelo para un partido es del 80% o más, ese partido será clasificado como “win”. Si es menor, el resultado predicho será de “lose”.
#Armo un listado con todos los modelos que voy a ajustar y sus formulas
vars <- list(model1 = "Round + PartidosUlt6Meses + PartidosUlt3Meses + PartidosUltMes + WRUlt6Meses + WRUlt3Meses + WRUltMes + PartidosRivalUltMes + WRRivalUltMes + ResultUltPartido",
model2 = "Surface + BestOf + RankNadal + RankRival + Round + PartidosUlt6Meses + PartidosUltMes + WRUlt6Meses + WRUltMes + PartidosRivalUltMes + WRRivalUltMes + ResultUltPartido",
model3 = "Surface + BestOf + RankNadal + RankRival + Round + PartidosUlt3Meses + PartidosUltMes + WRUlt3Meses + WRUltMes + PartidosRivalUltMes + WRRivalUltMes + ResultUltPartido",
model4 = "Surface + BestOf + RankNadal + RankRival + Round + PartidosUltMes + WRUltMes + PartidosRivalUltMes + WRRivalUltMes",
model5 = "Surface + PartidosUltMes + WRUltMes + PartidosUlt6Meses + WRUlt6Meses + PartidosRivalUltMes + WRRivalUltMes + ResultUltPartido + RoundUltPartido",
model6 = "RankNadal + RankRival + Round + PartidosUltMes + WRUltMes + PartidosRivalUltMes + WRRivalUltMes")
#Armo una tabla donde se almacenan los resultados de los ajustes
results <- tibble(modelo = paste("glm.fit", 1:6, sep = ""),
cv.accuracy = rep(0, 6),
accuracy.test = rep(0, 6),
FP.Ratio.test = rep(0, 6))
#Defino el train control. Sera repeated CV, con 10 particiones y 10 repeticiones
trainControl <- trainControl(method = "repeatedcv", number = 10, repeats = 10)
#Seteo semilla para que los resultados sean reproducibles
set.seed(1200)
#Defino la tasa de corte para el testeo
r <- 0.8
for (i in (1:nrow(results))) {
formula <- as.formula(paste("Result ~ ", paste(vars[i]), sep = ""))
model.fit <- train(formula,
data = df_matches_train,
trControl = trainControl,
method = "glm",
family = "binomial",
na.action = na.omit)
assign(paste("glm.fit", i, sep=""), model.fit)
results$cv.accuracy[i] = model.fit$results$Accuracy
probs <- predict(model.fit, type = "prob", newdata = df_matches_test)$Win
pred <- rep("Lose", nrow(df_matches_test))
pred[probs >= r] = "Win"
conf.matrix <- table(pred, actual = df_matches_test$Result)
results$accuracy.test[i] =
(conf.matrix[1,1] + conf.matrix[2,2])/nrow(df_matches_test)
results$FP.Ratio.test[i] =
conf.matrix[2,1]/(conf.matrix[1,1] + conf.matrix[2,1])
rm(formula, model.fit, probs, pred, conf.matrix)
}
results
Esta tabla resume, para cada modelo, la siguiente información:
El false-positive ratio es muy importante en este análisis ya que los partidos en los que Nadal sale derrotado son realmente pocos, con lo cual poder identificar esos pocos partidos donde Nadal no gana es algo de gran utilidad.
Basándonos exclusivamente en el error calculado por el método de cross-validation podemos concluir que todos los modelos tienen un rendimiento similar, y éste es en general muy bueno. Vamos a seleccionar el modelo número 3, que es el que tiene el mayor accuracy. Los modelos 2 y 3 tienen una composición de variables muy similar.
Veamos un resumen de este modelo:
#Resumen del modelo
summary(glm.fit3)
##
## Call:
## NULL
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -3.5546 0.0021 0.0291 0.1450 2.6825
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -6.778438 2.961447 -2.289 0.022086 *
## SurfaceClay 2.908957 1.432187 2.031 0.042242 *
## SurfaceGrass 0.304260 1.592178 0.191 0.848450
## SurfaceHard 1.225084 1.374534 0.891 0.372783
## BestOf5 1.610925 0.448292 3.593 0.000326 ***
## RankNadal 0.112774 0.094786 1.190 0.234134
## RankRival 0.004938 0.006959 0.709 0.478032
## `Round2nd Round` 4.478328 1.081618 4.140 0.0000346705 ***
## `Round3rd Round` 5.883500 1.221507 4.817 0.0000014603 ***
## `Round4th Round` 7.893391 1.475542 5.349 0.0000000882 ***
## RoundQuarterfinals 7.005116 1.337017 5.239 0.0000001611 ***
## `RoundRound Robin` 6.463257 1.493782 4.327 0.0000151310 ***
## RoundSemifinals 6.968001 1.351436 5.156 0.0000002523 ***
## `RoundThe Final` 7.507708 1.470520 5.105 0.0000003300 ***
## PartidosUlt3Meses -0.053316 0.038161 -1.397 0.162373
## PartidosUltMes -0.343398 0.086523 -3.969 0.0000722230 ***
## WRUlt3Meses 1.123033 3.401603 0.330 0.741288
## WRUltMes 25.560964 3.084910 8.286 < 0.0000000000000002 ***
## PartidosRivalUltMes 0.263832 0.073334 3.598 0.000321 ***
## WRRivalUltMes -24.940901 2.872932 -8.681 < 0.0000000000000002 ***
## ResultUltPartidoWin -2.516004 0.937238 -2.684 0.007264 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 907.78 on 1033 degrees of freedom
## Residual deviance: 236.34 on 1013 degrees of freedom
## AIC: 278.34
##
## Number of Fisher Scoring iterations: 8
Se observa que hay variables que no son significativas, como por ejemplo el ranking de los jugadores y el win rate de los últimos 3 meses de Nadal (poseen un p-value alto).
Vamos a sacar esas variables y analizar otra vez el accuracy del modelo.
#Nuevo ajuste eliminando variables con poco impacto en glm.fit3
glm.fit3.1 <- train(Result ~ Surface + BestOf + Round +
PartidosUltMes +WRUltMes + PartidosRivalUltMes +
WRRivalUltMes + ResultUltPartido,
data = df_matches_train,
trControl = trainControl,
method = "glm",
family = "binomial",
na.action = na.omit)
glm.fit3.1
## Generalized Linear Model
##
## 1034 samples
## 8 predictor
## 2 classes: 'Lose', 'Win'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 10 times)
## Summary of sample sizes: 930, 931, 930, 931, 931, 931, ...
## Resampling results:
##
## Accuracy Kappa
## 0.9509677 0.8102885
Vemos que con este nuevo ajuste mejoramos el accuracy con respecto al modelo glm.fit3
, con lo cual este será nuestro modelo final. Veamos cómo impactan las variables seleccionadas en la probabilidad de victoria de Nadal.
#Armamos un gráfico para ver cuales son las variables más significativas en términos de p-valor
tabl_glm3.1 <- glm.fit3.1 %>%
summary() %>%
coef() %>%
as_tibble() %>%
cbind(Variable = glm.fit3.1 %>%
summary() %>%
coef() %>% rownames(),.) %>%
mutate(Estimate = round(Estimate, 3),
pos = Estimate >= 0)
#Gráfico
tabl_glm3.1 %>%
ggplot(aes(x = reorder(Variable, -abs(Estimate)), y = Estimate, fill = pos)) +
geom_col(position = "identity") +
geom_text(aes(label = Estimate, vjust = -sign(Estimate))) +
labs(x = "",
y = "Beta Estimado") +
coord_cartesian(ylim = c(-30,30))+
theme_few() +
theme(axis.text.x = element_text(angle = 45,
size = 10,
vjust = 1,
hjust = 1),
legend.position = "none")
Se puede ver que las variables que tienen mayor impacto en la estimación de la probabilidad de victoria para cada partido son el win rate del rival en el último mes, el cual afecta negativamente la probabilidad de victoria, y el win rate de Nadal en el último mes, que afecta positivamente a la probabilidad de victoria. Esto es lógico, ya que un mayor porcentaje de victorias de Nadal en el último mes significa que llega al partido con una buena performance en los partidos previos, por lo que sus chances de victoria se incrementan. Exactamente lo opuesto sucede cuando el rival llega con un alto porcentaje de victorias.
Otro caso interesante es lo que sucede con la cantidad de partidos jugados en el último mes, tanto para Nadal como para el rival. Esta variable tiene el efecto opuesto a la de variable win rate, y es un tanto polémico. El modelo parece penalizar la probabilidad de victoria cuando el tenista (aplica tanto Nadal como el rival) viene con muchos partidos jugados en el último mes. Intuitivamente, lo que el modelo parece estar captando es que si el jugador llega con muchos partidos en el mes su probabilidad de victoria decae debido al cansancio acumulado.
Otra conclusión bastante obvia que se desprende del análisis es que si el partido se disputa sobre cancha lenta la probabilidad de victoria de Nadal crece, lo mismo sucede si el partido es al mejor de 5 sets.
En lo que respecta a los resultados predictivos del modelo, el mismo tiene una tasa de clasificación estimada por CV de más del 95%. Ahora bien, para obtener los mejores resultados predictivos debemos determinar el umbral de clasificación óptimo, es decir la probabilidad a partir de la cual vamos a clasificar un partido como victoria o derrota.
Una vez seleccionado el que creemos es nuestro mejor modelo, queda seleccionar el umbral de clasificación que utilizaremos para clasificar a un partido como “win” o “lose”. Este umbral se determinará mirando la curva ROC. Esta curva compara, para cada umbral (entre 0 y 1), dos métricas que son importantes y que calcularemos sobre la base de testeo:
El umbral óptimo de clasificación será el que nos deje con un alto TPR y un bajo FPR.
#Computo probabilidades utilizando el modelo seleccioado
probs <- predict(glm.fit3.1, type = "prob", newdata = df_matches_test)$Win
#Armo factores para curva ROC
ROC_curve <- tibble(
Umbral = rep(0, 39),
TN = rep(0, 39),
FN = rep(0, 39),
FP = rep(0, 39),
TP = rep(0, 39))
for (j in 1:39){
corte <- j/40
pred <- rep("Lose", nrow(df_matches_test))
pred[probs > corte] = "Win"
ROC_curve[j,1] = corte
ROC_curve[j,2] = table(pred, df_matches_test$Result)[1,1]
ROC_curve[j,3] = table(pred, df_matches_test$Result)[1,2]
ROC_curve[j,4] = table(pred, df_matches_test$Result)[2,1]
ROC_curve[j,5] = table(pred, df_matches_test$Result)[2,2]
rm(corte, pred)
}
ROC_curve %<>%
mutate(TPR = TP/(TP+FN),
FPR = FP/(FP+TN))
ROC_curve
Observando la evolución del TPR y el FPR, podemos concluir que un umbral de clasificación razonable y óptimo parece ser 0.925. Priorizamos bajar el FPR al mínimo ya que es de nuestro interés poder identificar aquellos partidos donde Nadal pierde, partidos que claramente son los menos.
La matriz de confusión final, para la base de testeo post receso quedaría de la siguiente manera:
#computo matriz de confusion final para base de testeo
corte <- 0.925
pred <- rep("Lose", nrow(df_matches_test))
pred[probs > corte] = "Win"
table(pred, real = df_matches_test$Result)
## real
## pred Lose Win
## Lose 7 2
## Win 1 35
Se observa que hay solo un partido donde Nadal no ganó que queda mal clasificado, partido en el que Nadal tenía una alta probabilidad de victoria y sin embargo perdió. Veamos de qué partido se trata.
#identifico partido perdido mal clasificado
cual <- which(pred != df_matches_test$Result)
df_matches_test[cual,] %>% filter(Result == "Lose")
El partido en cuestión corresponde a los cuartos de final del Masters 1000 de Roma, donde Rafael Nadal cayó ante Diego Schwartzman. Sin dudas se trató de una derrota inesperada, ya que la superficie y el ranking jugaban a favor de Nadal. El porcentaje de victorias de Schwartzman en los últimos 3 meses tampoco era demasiado bueno. Sin dudas se trató de un resultado inesperado y, por supuesto, de un gran partido de Diego.
Como conclusión final, podemos decir que el modelo de regresión logística funciona muy bien para predecir el resultado de un partido de Rafael Nadal. Sin dudas el fuerte de esta técnica es su capacidad explicativa, que permite no solo ver qué variables son las que muestran una fuerte influencia sobre el resultado, sino que además podemos ver en qué dirección afectan el mismo.
Como modelo predictivo el desempeño también es muy bueno, logrando una precisión de clasificación del 95%, precisión que fue estimada de una forma insesgada utilizando cross validation.
Sin dudas, lo más importante es la capacidad del modelo para detectar aquellos partidos en donde Nadal pierde, ya que es algo que rara vez sucede.