Support Vector Machine - Aplicación en el Tenis
Tomás Roel
July 14, 2021
Introducción
Este documento es una continuación del primer trabajo realizado acerca de clasificación en partidos de tenis, el cual podrán encontrar siguiendo este link https://rpubs.com/tomroel/regresion-logistica-rafael-nadal y en donde se aplican modelos de Regresión Logística para intentar predecir el resultado de un partido de tenis de Rafael Nadal, partido que solo tiene dos resultados posibles: victoria o derrota.
Repasando el problema, el mismo consiste en utilizar un set de variables acerca del contexto del partido y de la condición en que cada uno de los tenistas llega a disputar el encuentro para predecir quién será el ganador del mismo.
Support Vector Machine
En esta ocasión, probaremos un modelo un tanto más complejo que el modelo de Regresión Logística. Trabajaremos con Support Vector Machine, un método muy flexible, utilizado principalmente para problemas de clasificación binaria y que en general tiene muy buena performance en problemas complejos.
No ahondaremos en una descripción detallada del método ya que existe vasta literatura acerca del mismo. Solo diremos que el método intenta buscar para separar las clases (victoria y derrota, “win” y “lose” en nuestro problema) el mejor hiperplano separador que exista, entendiendo por esto aquel hiperplano separador que deje el mayor margen posible entre las clases. Ahora bien, si este método separa con un hiperplano, para obtener un buen resultado necesitaríamos aplicarlo a un problema donde contemos con clases que sean linealmente separables. De ser así, esto sería una gran limitación para el método ya que son pocos los problemas que cuentan con estas características. Afortunadamente, Support Vector Machine logra superar este inconveniente utilizando una técnica que se conoce como kernel trick y es la clave de por qué este método es tan potente. Esencialmente, el kernel trick consiste en aplicar una transformación a las observaciones con el objetivo de aumentar la dimensionalidad del problema, llevándolo a un terreno más complejo donde ahora las clases sí sean linealmente separables y donde pueda estimar el hiperplano separador de forma correcta.
Desarrollo
En las próximas secciones iremos desarrollando, paso a paso, la aplicación de Support Vector Machine (SVM de ahora en más) a nuestro problema de clasificación. Todo el trabajo ha sido realizado usando R como herramienta principal.
Setup
Arrancamos con un setup del environment donde vamos a trabajar.
#Cargo librerias de interes
pacman::p_load(pacman, tidyverse, rio, magrittr, lubridate,
RColorBrewer, caret, e1071, readr, rgl, cluster, Rtsne, ggthemes,
ROSE)
options(scipen = 999) #Elimino notacion cientifica
options(rgl.useNULL = TRUE) #Gráficos 3D interactivosImportamos la base de datos con la que trabajaremos.
#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)
rm(matches_nadal_ok, path, variables)
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.)
Data Wrangling
Con la base ya cargada, hacemos unos ajustes necesarios previos al análisis. SVM necesita como input una matriz numérica, con lo cual debemos transformar todas las variables categóricas haciendo un one hot encoding. Otro ajuste que haremos a la base será estandarizar todas las variables numéricas para que tomen valores entre 0 y 1. Estas modificaciones las haremos en un pre-procesamiento de los datos antes del ajuste del modelo.
#Elimino variables que no son de interes
df_matches <- df_matches[,-c(1,2)]
#Elimino observaciones que no me sirven porque no tengo registro de los partidos anteriores
df_matches %>%
select(RankNadal,PartidosUlt6Meses, PartidosUlt3Meses, PartidosUltMes) %>%
print(n = 70)## # A tibble: 1,129 x 4
## RankNadal PartidosUlt6Meses PartidosUlt3Meses PartidosUltMes
## <dbl> <dbl> <dbl> <dbl>
## 1 51 1 1 1
## 2 51 2 2 2
## 3 51 3 3 3
## 4 50 4 4 4
## 5 56 5 5 5
## 6 56 6 6 6
## 7 56 7 7 7
## 8 56 8 8 8
## 9 48 9 9 6
## 10 48 10 10 6
## 11 48 11 11 7
## 12 48 12 12 8
## 13 48 14 14 9
## 14 48 14 14 9
## 15 48 15 15 9
## 16 48 16 16 10
## 17 39 17 17 10
## 18 39 18 18 10
## 19 39 19 19 11
## 20 39 20 20 12
## 21 39 21 21 13
## 22 31 22 22 4
## 23 31 23 23 4
## 24 31 24 24 3
## 25 31 25 25 4
## 26 31 26 26 5
## 27 31 27 27 6
## 28 17 28 25 7
## 29 17 29 26 8
## 30 17 30 27 9
## 31 17 31 27 10
## 32 17 32 28 11
## 33 17 33 29 12
## 34 17 34 30 13
## 35 17 35 31 14
## 36 17 36 32 15
## 37 11 37 31 16
## 38 11 38 32 17
## 39 11 39 32 18
## 40 11 40 33 19
## 41 11 41 33 19
## 42 7 42 34 15
## 43 7 43 35 16
## 44 7 44 36 17
## 45 7 45 37 17
## 46 7 46 38 17
## 47 7 47 39 17
## 48 5 48 31 8
## 49 5 49 31 8
## 50 5 50 30 9
## 51 5 51 30 10
## 52 5 52 31 11
## 53 5 53 32 10
## 54 5 54 33 9
## 55 3 55 34 8
## 56 3 56 35 9
## 57 3 57 35 9
## 58 3 55 30 4
## 59 3 56 29 5
## 60 3 57 30 5
## 61 3 58 31 6
## 62 3 58 31 7
## 63 3 57 25 8
## 64 3 57 25 8
## 65 3 58 25 9
## 66 3 58 25 9
## 67 3 59 26 10
## 68 2 58 21 6
## 69 2 59 23 8
## 70 2 59 23 8
## # ... with 1,059 more rows#Elimino primeras 50 observaciones, a partir de ahi se nivela
df_matches <- df_matches[51:nrow(df_matches),]Plots
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 Rafel Nadal en el circuito cuando segmentamos los partidos por alguna de las variables que tenemos disponibles.
#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()
#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))
Obtenemos algunas conclusiones de estos gráficos:
- Cuando Nadal llega con ritmo (cantidad de partidos) y con buen porcentaje de victorias (WR) parece ser más probable que obtenga una victoria en el partido.
- Si el rival forma parte del top 10, las chances de derrota son mayores.
- El clay (polvo de ladrillo) es sin dudas la superficie que mejor le sienta.
- A 5 sets parece haber una mejor performance en general de Nadal.
- En las primeras rondas del torneo tiende a tener un porcentaje de victorias mayor.
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.
Reducción de Dimensionalidad
Antes de comenzar con el ajuste de los modelos, sería interesante poder ver a las observaciones en un gráfico tridimensional. Obviamente, al estar trabajando en un espacio muy grande (tenemos 24 covariables) no podemos graficarlas usando toda la información disponible, sino que tenemos que usar una técnica de reducción de dimensionalidad.
La técnica a utilizar será t-Distributed Stochastic Neighbor Embedding (T-SNE). Esta metodología logra aproximar las observaciones que viven en un espacio muy grande en uno mucho más pequeño que permite graficarlas (2 o 3 dimensiones). Para más información sobre el tema recomiendo ver los videos que Andrés Farall tiene publicados acerca del mismo: https://www.youtube.com/playlist?list=PLN2e9R_DoC0TjZtHGm8-PFifxzE9KwilZ.
T-SNE requiere del cálculo de distancias entre observaciones para hacer la reducción de dimensionalidad. Si las variables son continuas, generalmente se utiliza la distancia euclídea, pero si son categóricas tendremos que usar otra fórmula de cálculo. En nuestro caso, poseemos un mix de variables continuas y categóricas, con lo cual utilizaremos la distancia Gower. Este concepto de distancia consiste en aplicar una fórmula diferente según el tipo de variables que estemos midiendo y luego aplicarle una función para que el valor final caiga entre 0 y 1.
#Matriz de distancias
gower_dist <- daisy(df_matches[,-c(3,25)],
metric = "gower",
type = list(logratio = 3))
summary(gower_dist)## 581581 dissimilarities, summarized :
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.01892 0.22645 0.28273 0.28697 0.34350 0.71387
## Metric : mixed ; Types = N, N, N, N, I, I, I, I, I, I, I, I, I, I, I, I, I, I, I, I, N, N, I, N
## Number of objects : 1079gower_mat <- as.matrix(gower_dist)
#Observaciones más disímiles
df_matches[which(gower_mat == max(gower_mat[gower_mat != max(gower_mat)]),
arr.ind = TRUE)[1, ], ] #Vemos con son muy distintas#Reducción de dimensión con tsne
tsne_obj <- Rtsne(gower_dist, is_distance = TRUE, dims = 3)
#Default perplexity is 0.5
tsne_data <- tsne_obj$Y %>%
as_tibble %>%
mutate(Result = df_matches %>% pull(Result)) %>%
mutate(Result = recode(Result, "1" = "Win", "0" = "Lose"))
#Colores
color <- rep("green", nrow(df_matches))
color[which(df_matches[,25]==0)] = "red"
#Ploteo 3D
plot3d(tsne_data[1:3], col = color)
rglwidget()En el gráfico tridimensional podemos ver la representación en baja dimensión que obtenemos mediante la aplicación de T-SNE. Las observaciones rojas representan los partidos perdidos por Nadal, mientras que las verdes representan los ganados. Se puede ver que hay zonas con mayor cantidad de rojos, zonas que vamos a intentar identificar mediante la aplicación de SVM.
Tasas de Corte
Vamos a utilizar un modelo de clasificación 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.8363636Las tasas históricas de victoria de Rafael Nadal son las siguientes:
- Histórica: 83.97%
- A partir de 2019: 84.75%
- 2020 en adelante: 83.64%
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.
Model Train
Llegamos hasta acá con una buena impresión de cómo lucen los datos. Ahora vamos a construir nuestro modelo predictivo aplicando Support Vector Machine.
Estrategia de Entrenamiento-Testeo
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.
Ajuste de modelos
Trabajamos con un kernel RBF, con lo cual vamos a tener dos parámetros que van a regular la complejidad del modelo: el parámetro de costo C (regula cuánta importancia le doy a las observaciones mal clasificadas para ajustar el hiperplano) y el parámetro Gamma (sigma en el paquete caret) que es propio del tipo de kernel que estamos utilizando y en el fondo va a regular el overfitting del modelo.
Para encontrar el C y el sigma óptimos haremos un grid search utilizando las herramientas que nos provee la librería caret.
#Train_contol. Cross Validation.
train_control <- trainControl(method = "repeatedcv",
number = 10,
repeats = 5)
#Grid para hacer un gridsearch de parámetros
grid <- expand.grid(C = seq(4.9,5.1,0.1),
sigma = seq(0.01,0.017,0.0005))
#Data test y train
data_train <- df_matches %>%
filter(Date < "2020-04-01") %>%
select(-Date)
data_test <- df_matches %>%
filter(Date >= "2020-04-01") %>%
select(-Date)
#Entrenamiento con dataset train
set.seed(1234)
svm.fit <- train(Result ~.,
data = data_train,
method = "svmRadial",
trControl = train_control,
preProcess = c("center", "scale"),
tuneGrid = grid,
na.action = na.omit)
#Mejor C y el mejor sigma que maximizan accuracy
svm.fit$bestTune#Resumen del modelo
svm.fit## Support Vector Machines with Radial Basis Function Kernel
##
## 1034 samples
## 24 predictor
## 2 classes: 'Lose', 'Win'
##
## Pre-processing: centered (38), scaled (38)
## Resampling: Cross-Validated (10 fold, repeated 5 times)
## Summary of sample sizes: 918, 917, 916, 917, 918, 917, ...
## Resampling results across tuning parameters:
##
## C sigma Accuracy Kappa
## 4.9 0.0100 0.9472190 0.7806878
## 4.9 0.0105 0.9462386 0.7763030
## 4.9 0.0110 0.9466211 0.7786579
## 4.9 0.0115 0.9466211 0.7793624
## 4.9 0.0120 0.9470133 0.7810063
## 4.9 0.0125 0.9477995 0.7844925
## 4.9 0.0130 0.9481917 0.7861874
## 4.9 0.0135 0.9495624 0.7914482
## 4.9 0.0140 0.9487800 0.7881501
## 4.9 0.0145 0.9483859 0.7866774
## 4.9 0.0150 0.9483878 0.7867595
## 4.9 0.0155 0.9479975 0.7860888
## 4.9 0.0160 0.9478015 0.7850926
## 4.9 0.0165 0.9468172 0.7811885
## 4.9 0.0170 0.9460348 0.7785577
## 5.0 0.0100 0.9472190 0.7806878
## 5.0 0.0105 0.9466269 0.7780554
## 5.0 0.0110 0.9466211 0.7785016
## 5.0 0.0115 0.9472113 0.7815593
## 5.0 0.0120 0.9476034 0.7835561
## 5.0 0.0125 0.9481917 0.7864402
## 5.0 0.0130 0.9485839 0.7879333
## 5.0 0.0135 0.9493663 0.7905715
## 5.0 0.0140 0.9487800 0.7881501
## 5.0 0.0145 0.9483859 0.7867033
## 5.0 0.0150 0.9485839 0.7878808
## 5.0 0.0155 0.9483897 0.7876567
## 5.0 0.0160 0.9478015 0.7850926
## 5.0 0.0165 0.9464250 0.7798416
## 5.0 0.0170 0.9456426 0.7772144
## 5.1 0.0100 0.9472171 0.7806091
## 5.1 0.0105 0.9468211 0.7793843
## 5.1 0.0110 0.9464250 0.7779731
## 5.1 0.0115 0.9472113 0.7815593
## 5.1 0.0120 0.9474074 0.7825028
## 5.1 0.0125 0.9481898 0.7863503
## 5.1 0.0130 0.9491702 0.7903726
## 5.1 0.0135 0.9491702 0.7898039
## 5.1 0.0140 0.9487780 0.7883200
## 5.1 0.0145 0.9489760 0.7891822
## 5.1 0.0150 0.9481936 0.7869517
## 5.1 0.0155 0.9481936 0.7869852
## 5.1 0.0160 0.9474074 0.7839183
## 5.1 0.0165 0.9462290 0.7793611
## 5.1 0.0170 0.9462328 0.7795501
##
## Accuracy was used to select the optimal model using the largest value.
## The final values used for the model were sigma = 0.0135 and C = 4.9.#Prueba sobre base de testeo y matriz de confusión
pred <- predict(svm.fit, newdata = data_test)
confusionMatrix(pred,data_test$Result)## Confusion Matrix and Statistics
##
## Reference
## Prediction Lose Win
## Lose 3 0
## Win 5 37
##
## Accuracy : 0.8889
## 95% CI : (0.7595, 0.9629)
## No Information Rate : 0.8222
## P-Value [Acc > NIR] : 0.16491
##
## Kappa : 0.4966
##
## Mcnemar's Test P-Value : 0.07364
##
## Sensitivity : 0.37500
## Specificity : 1.00000
## Pos Pred Value : 1.00000
## Neg Pred Value : 0.88095
## Prevalence : 0.17778
## Detection Rate : 0.06667
## Detection Prevalence : 0.06667
## Balanced Accuracy : 0.68750
##
## 'Positive' Class : Lose
## Como se puede ver, el mejor modelo que pudimos conseguir posee una accuracy de 94.96%. Los parámetros con los que se logran estos resultados son:
- C = 4.9
- Sigma (Gamma) = 0.0135
Este resultado es prácticamente igual al que obtuvimos con Regresión Logística, donde el mejor modelo que pudimos entrenar tuvo una accuracy del 95%.
Viendo la matriz de confusión con las predicciones sobre la base de testeo, estas no son tan buenas como los que obtuvimos utilizando Regresión Logística. Podmos observar que la sensibilidad del modelo sobre la base de testeo es muy baja, lo que quiere decir que tiene problemas para detectar los partidos en donde Nadal pierde. Utilizando Regresión Logística tenemos la ventaja de que rápidamente podemos calcular la probabilidad de victoria para cada observación en la base de testeo y ajustar el umbral de clasificación para obtener mejores resultados predictivos.
Balanceo del Dataset
Esta mala performance de SVM para detectar los partidos en donde Nadal pierde puede deberse a que el dataset está sumamente desbalanceado. Con esto queremos decir que hay muchas más observaciones de una clase que de la otra (muchos más partidos ganados que perdidos). Veamos, sobre la base de entrenamiento, cómo están distribuidas las clases.
data_train %>%
select(Result) %>%
table(Result = .) %>%
prop.table() %>%
round(2) %>%
as_tibble() %>%
rename(Prop = n) %>%
ggplot(aes(x = Result, y = Prop, fill = Result)) +
geom_bar(stat = "identity") +
scale_fill_brewer(palette = "Set1") +
geom_text(aes(label = Prop, vjust = -0.5)) +
coord_cartesian(ylim = c(0, 1)) +
labs(y = "Proporción") +
theme_few() +
theme(legend.position = "none")
Vemos que más del 80% de los partidos en la base train corresponden a partidos ganados. Esto termina perjudicando la performance del modelo, ya que al tener pocos partidos perdidos de los cuales aprender, le termina siendo difícil identificarlos.
Afortunadamente tenemos una posible solución para esto. Vamos a volver a realizar el ajuste de SVM, pero esta vez realizaremos un balanceo previo del dataset utilizando una técnica conocida como Random Oversampling. Esta técnica consiste en emparejar la distribución de clases del dataset completando la base de entrenamiento con un muestreo con reposición de observaciones de la clase minoritaria.
#Generamos nueva base balanceada
train_over <- ovun.sample(Result~.,
data = data_train,
method = "over",
N = 1700)$data
#Visualizamos la distribución de clases
train_over %>%
select(Result) %>%
table(Result = .) %>%
prop.table() %>%
round(2) %>%
as_tibble() %>%
ggplot(aes(x = Result, y = n, fill = Result)) +
geom_bar(stat = "identity") +
geom_text(aes(label = n, vjust = -0.5)) +
coord_cartesian(ylim = c(0,1)) +
scale_fill_brewer(palette = "Set1") +
theme_few()+
theme(legend.position = "none")
#Definimos grid para el grid search
grid2 <- expand.grid(C = seq(25,35,1),
sigma = seq(0.015,0.018,0.001))
#Entrenamiento con dataset train
set.seed(1234)
svm.fit2 <- train(Result ~.,
data = train_over,
method = "svmRadial",
trControl = train_control,
preProcess = c("center", "scale"),
tuneGrid = grid2,
na.action = na.omit)
#Mejor C y el mejor sigma que maximizan accuracy
svm.fit2$bestTune#Resumen del modelo
svm.fit2## Support Vector Machines with Radial Basis Function Kernel
##
## 1700 samples
## 24 predictor
## 2 classes: 'Win', 'Lose'
##
## Pre-processing: centered (38), scaled (38)
## Resampling: Cross-Validated (10 fold, repeated 5 times)
## Summary of sample sizes: 1531, 1530, 1529, 1530, 1530, 1530, ...
## Resampling results across tuning parameters:
##
## C sigma Accuracy Kappa
## 25 0.015 0.9772966 0.9546079
## 25 0.016 0.9774136 0.9548419
## 25 0.017 0.9776496 0.9553129
## 25 0.018 0.9777693 0.9555522
## 26 0.015 0.9771790 0.9543726
## 26 0.016 0.9772959 0.9546066
## 26 0.017 0.9776496 0.9553129
## 26 0.018 0.9780039 0.9560210
## 27 0.015 0.9775312 0.9550771
## 27 0.016 0.9772959 0.9546065
## 27 0.017 0.9774143 0.9548433
## 27 0.018 0.9781215 0.9562559
## 28 0.015 0.9776496 0.9553138
## 28 0.016 0.9772966 0.9546081
## 28 0.017 0.9776496 0.9553133
## 28 0.018 0.9784731 0.9569589
## 29 0.015 0.9772959 0.9546068
## 29 0.016 0.9774136 0.9548419
## 29 0.017 0.9775319 0.9550782
## 29 0.018 0.9788260 0.9576648
## 30 0.015 0.9770606 0.9541367
## 30 0.016 0.9775312 0.9550771
## 30 0.017 0.9777665 0.9555471
## 30 0.018 0.9787084 0.9574296
## 31 0.015 0.9770606 0.9541367
## 31 0.016 0.9775312 0.9550771
## 31 0.017 0.9782371 0.9564877
## 31 0.018 0.9787077 0.9574283
## 32 0.015 0.9771776 0.9543706
## 32 0.016 0.9777658 0.9555459
## 32 0.017 0.9782371 0.9564882
## 32 0.018 0.9788254 0.9576634
## 33 0.015 0.9774129 0.9548408
## 33 0.016 0.9776482 0.9553108
## 33 0.017 0.9782371 0.9564882
## 33 0.018 0.9788254 0.9576634
## 34 0.015 0.9774129 0.9548409
## 34 0.016 0.9775305 0.9550757
## 34 0.017 0.9783541 0.9567219
## 34 0.018 0.9789430 0.9578986
## 35 0.015 0.9771769 0.9543694
## 35 0.016 0.9777658 0.9555465
## 35 0.017 0.9783541 0.9567219
## 35 0.018 0.9792973 0.9586067
##
## Accuracy was used to select the optimal model using the largest value.
## The final values used for the model were sigma = 0.018 and C = 35.#Prueba sobre base de testeo y matriz de confusión
pred <- predict(svm.fit2, newdata = data_test)
confusionMatrix(pred,data_test$Result)## Confusion Matrix and Statistics
##
## Reference
## Prediction Lose Win
## Lose 4 0
## Win 4 37
##
## Accuracy : 0.9111
## 95% CI : (0.7878, 0.9752)
## No Information Rate : 0.8222
## P-Value [Acc > NIR] : 0.07863
##
## Kappa : 0.6218
##
## Mcnemar's Test P-Value : 0.13361
##
## Sensitivity : 0.50000
## Specificity : 1.00000
## Pos Pred Value : 1.00000
## Neg Pred Value : 0.90244
## Prevalence : 0.17778
## Detection Rate : 0.08889
## Detection Prevalence : 0.08889
## Balanced Accuracy : 0.75000
##
## 'Positive' Class : Lose
## Vemos que con este nuevo ajuste logramos aumentar la sensibilidad sobre la base de testeo, es decir el porcentaje de partidos perdidos que el modelo clasifica correctamente.
De todas formas, no pudimos lograr una performance tan buena sobre esta base como la que obtuvimos con Regresión Logística.
Conclusión
Los resultados predictivos que surgen de la aplicación de SVM a nuestro problema sin dudas son buenos. El accuracy calculado utilizando cross-validation es significativamente más alto que el mínimo de 85% que establecimos mirando la performance histórica de Nadal. Sin embargo, viendo que los resultados obtenidos con Regresión Logística son muy parecidos, si tuviésemos que elegir entre ambos métodos tenderíamos a elegir el modelo de Regresión, ya que es una técnica mucho más fácil de comprender y con mayor capacidad explicativa.
De todas formas, SVM no deja de ser un método super flexible y con gran potencial. Aquí hemos probado un solo tipo de kernel, con lo cual queda abierta la puerta para seguir investigando otras soluciones que puedan dar mejores resultados.