Machine Learning Analysis - Prova2

Exercício 1 (3,5 pontos)

O objetivo do exercício é predizer a taxa de crimes de estados americanos, utilizar os shapvalues para avaliar a contribuição das variáveis no modelo e identificar observações atípicas. Para isso utilize alguma técnica de predição e um banco de treinamento de \(70\)%.

require(MASS)
library(tidyverse)
library(caret)
library(DT)
library(knitr)
library(lessR)

data('UScrime')

Renomeando as variáveis do banco

UScrime_data = UScrime
UScrime_data$So = as.factor(UScrime_data$So)
Variável = names(UScrime_data)
Variável_Renomeada =c("percent_m", "is_south", "mean_education", "police_exp60", "police_exp59", "labour_participation", "m_per1000f", "state_pop", "nonwhites_per1000", "unemploy_m24", "unemploy_m39", "gdp", "inequality", "prob_prison", "time_prison", "crime_rate")
names(UScrime_data) = Variável_Renomeada
tabela = cbind(Variável, Variável_Renomeada)
# names(tabela) = c("Variável", "Variável Renomeada")
kable(tabela)

Variável	Variável_Renomeada
M	percent_m
So	is_south
Ed	mean_education
Po1	police_exp60
Po2	police_exp59
LF	labour_participation
M.F	m_per1000f
Pop	state_pop
NW	nonwhites_per1000
U1	unemploy_m24
U2	unemploy_m39
GDP	gdp
Ineq	inequality
Prob	prob_prison
Time	time_prison
y	crime_rate

Atenção: Para toda a análise eu não vou considerar o banco padronizado porque nesse banco tem a variável So (is_south) que é categórica e por isso não possui média e padronizar essa variável dificulta minha análise e não acho legal remover essa variável por conta da padronização. Favor considerar minha análise tal como é.

a1) Fazendo uma análise descritiva. (1 ponto)

Descritivas das variáveis contínuas numéricas

standard_desviation = numeric(0)
variance = numeric(0)
min_var = numeric(0)
max_var = numeric(0)
mediana_var = numeric(0)
media_var = numeric(0)

for (i in (c(1,3:16))){
  
  standard_desviation = append(standard_desviation, sd(UScrime_data[,i]))
  variance = append(variance, var(UScrime_data[,i]))
  min_var = append(min_var, min(UScrime_data[,i]))
  max_var = append(max_var, max(UScrime_data[,i]))
  mediana_var = append(mediana_var, median(UScrime_data[,i]))
  media_var = append(media_var, mean(UScrime_data[,i]))}



Desvio_padrao = standard_desviation
Variancia = variance
Minimo = min_var
Maximo = max_var
Mediana = mediana_var
Media = media_var

banco_summary = rbind(Desvio_padrao, Variancia, Minimo, Maximo, Mediana, Media)

rownames(banco_summary) = c("Desvio_Padrão", "Variância", "Mínimo", "Máximo", "Mediana", "Média")

colnames(banco_summary) = names(UScrime_data)[c(1,3:16)]

banco_summary =  banco_summary %>% round(2)

knitr::kable (banco_summary)

	percent_m	mean_education	police_exp60	police_exp59	labour_participation	m_per1000f	state_pop	nonwhites_per1000	unemploy_m24	unemploy_m39	gdp	inequality	prob_prison	time_prison	crime_rate
Desvio_Padrão	12.57	11.19	29.72	27.96	40.41	29.47	38.07	102.83	18.03	8.45	96.49	39.9	0.02	7.09	386.76
Variância	157.95	125.15	883.22	781.84	1633.11	868.33	1449.42	10573.77	325.04	71.33	9310.50	1591.7	0.00	50.22	149585.38
Mínimo	119.00	87.00	45.00	41.00	480.00	934.00	3.00	2.00	70.00	20.00	288.00	126.0	0.01	12.20	342.00
Máximo	177.00	122.00	166.00	157.00	641.00	1071.00	168.00	423.00	142.00	58.00	689.00	276.0	0.12	44.00	1993.00
Mediana	136.00	108.00	78.00	73.00	560.00	977.00	25.00	76.00	92.00	34.00	537.00	176.0	0.04	25.80	831.00
Média	138.57	105.64	85.00	80.23	561.19	983.02	36.62	101.13	95.47	33.98	525.38	194.0	0.05	26.60	905.09

Comentário: Podemos observar a partir das medidas de variabilidade descritas acima que teve uma maior variância na variável taxa de crime do que nas outras variáveis.

Histograma de cada variável

# Histograma
for (i in (c(1,3:16))){

  hist(UScrime_data[, i], col = "purple", xlab = names(UScrime_data)[i],  main = paste0("Histograma da variável", " ",  names(UScrime_data)[i]))

}

Comentário: Olhando todos os histogramas em cima, parece que nenhuma variável apresenta uma distribuição normal. A maioria das variáveis apresentou uma distribuição assimétrica à direita.

Descritivas da única variável categórica: So (is_south)

is_south_table <- table(UScrime_data$is_south)

knitr::kable(is_south_table)

Var1	Freq
0	31
1	16

# pie(is_south_table)

is_south_df <- data.frame(is_south_var = UScrime_data$is_south)




PieChart(is_south_var, hole = 0, values = "%", data = is_south_df,
         fill = c("lightblue", "pink"), main = " Gráfico de pizza representando o comportamento da variável is_south")

## >>> suggestions
## PieChart(is_south_var, hole=0)  # traditional pie chart
## PieChart(is_south_var, values="%")  # display %'s on the chart
## PieChart(is_south_var)  # bar chart
## Plot(is_south_var)  # bubble plot
## Plot(is_south_var, values="count")  # lollipop plot 
## 
## --- is_south_var --- 
## 
##                    0      1    Total 
## Frequencies:      31     16       47 
## Proportions:   0.660  0.340    1.000 
## 
## Chi-squared test of null hypothesis of equal probabilities 
##   Chisq = 4.787, df = 1, p-value = 0.029

Comentário: Olhando a descritiva é possível reparar que no banco de dados tem uma maior proporção de estados que não ficam no sul do Estados Unidos (66%)

Boxplot de visualização da taxa de crime em função da variável is_south

# Boxplot

boxplot(crime_rate~ is_south, col = c("blue", "purple"), data = UScrime_data, main = "Boxplot da taxa de crime em função do estado ser do sul ou não")

Comentário: Olhando o boxplot acima podemos dizer que tem uma maior variância na tax ade crime dos estados que não são localizados no sul dos EUA. Porém parece que a mediana de taxa de crime nos estados que não se localizam no sul dos EUA não ficou muito diferente da mediana da taxa de crime nos estados que ficam no sul do país. Isso pode talvez ser um sinal de alerta de que apesar de não ter muitos estados no sul dos EUA a taxa de crime não deve ser negligenciada.

b1) Utilizando um modelo de predição e interprete os resultados. (0.75 ponto)

Técnica de Gradient Boosting - XGBoost

# Instale o pacote neuralnet se ainda não o tiver instalado # 
# install.packages("SHAPforxgboost")
# install.packages("here")

suppressPackageStartupMessages({
library("SHAPforxgboost"); library("ggplot2"); library("xgboost")
library("data.table"); library("here")
})

set.seed(00316695)
idx <- createDataPartition(UScrime_data$crime_rate, 
                           p = 0.7, ## proporcao de dados do banco de treinamento
                           list = FALSE, 
                           times = 1)

UScrime_train <- UScrime_data[ idx,]
UScrime_test  <- UScrime_data[-idx,]


# Definindo os preditores e a variável resposta no banco de treinamento

UScrime_train_x = data.matrix(UScrime_train[, -16])
UScrime_train_y = UScrime_train[,16]

#Definindo os preditores e a variável resposta no banco de teste
UScrime_test_x = data.matrix(UScrime_test[, -16])
UScrime_test_y = UScrime_test[, 16]



#definindo os bancos de treinamento e de teste finais
xgb_train = xgb.DMatrix(data = UScrime_train_x, label = UScrime_train_y)
xgb_test = xgb.DMatrix(data = UScrime_test_x, label = UScrime_test_y)


#define watchlist
watchlist = list(train=xgb_train, test=xgb_test)


#Ajustando XGBoost model and exbibindo treinamento e teste para cada round

model = xgb.train(data = xgb_train, max.depth = 3, watchlist=watchlist, nrounds = 70)

## [1]  train-rmse:726.406792   test-rmse:745.921830 
## [2]  train-rmse:546.017491   test-rmse:611.212878 
## [3]  train-rmse:411.338509   test-rmse:480.464381 
## [4]  train-rmse:314.540280   test-rmse:419.424215 
## [5]  train-rmse:240.057244   test-rmse:362.176862 
## [6]  train-rmse:185.471441   test-rmse:328.471211 
## [7]  train-rmse:147.626951   test-rmse:306.791168 
## [8]  train-rmse:119.118409   test-rmse:299.879987 
## [9]  train-rmse:98.424314    test-rmse:287.532993 
## [10] train-rmse:83.682043    test-rmse:278.515887 
## [11] train-rmse:70.811392    test-rmse:276.297439 
## [12] train-rmse:60.987716    test-rmse:274.615980 
## [13] train-rmse:53.207210    test-rmse:273.867593 
## [14] train-rmse:46.891701    test-rmse:274.864270 
## [15] train-rmse:41.226321    test-rmse:275.800556 
## [16] train-rmse:36.717184    test-rmse:276.455546 
## [17] train-rmse:31.922623    test-rmse:276.753355 
## [18] train-rmse:29.120385    test-rmse:277.429437 
## [19] train-rmse:25.653941    test-rmse:278.113612 
## [20] train-rmse:23.632966    test-rmse:278.525046 
## [21] train-rmse:19.759473    test-rmse:278.057747 
## [22] train-rmse:17.518519    test-rmse:277.784081 
## [23] train-rmse:14.665317    test-rmse:277.270309 
## [24] train-rmse:13.609086    test-rmse:277.240081 
## [25] train-rmse:12.149418    test-rmse:277.280978 
## [26] train-rmse:10.732580    test-rmse:277.417267 
## [27] train-rmse:9.588541 test-rmse:276.659006 
## [28] train-rmse:8.757372 test-rmse:276.855646 
## [29] train-rmse:8.246844 test-rmse:276.919565 
## [30] train-rmse:7.566761 test-rmse:276.485888 
## [31] train-rmse:6.553811 test-rmse:276.414783 
## [32] train-rmse:6.132228 test-rmse:276.049486 
## [33] train-rmse:5.620060 test-rmse:276.205312 
## [34] train-rmse:5.145789 test-rmse:276.234221 
## [35] train-rmse:4.778358 test-rmse:276.215356 
## [36] train-rmse:4.452178 test-rmse:276.203422 
## [37] train-rmse:3.908283 test-rmse:276.211865 
## [38] train-rmse:3.541868 test-rmse:275.995868 
## [39] train-rmse:3.252943 test-rmse:276.120349 
## [40] train-rmse:2.989052 test-rmse:275.813695 
## [41] train-rmse:2.847534 test-rmse:275.789808 
## [42] train-rmse:2.526310 test-rmse:275.755840 
## [43] train-rmse:2.337540 test-rmse:275.801308 
## [44] train-rmse:2.130027 test-rmse:275.690381 
## [45] train-rmse:1.986222 test-rmse:275.696910 
## [46] train-rmse:1.857366 test-rmse:275.826186 
## [47] train-rmse:1.720452 test-rmse:275.848942 
## [48] train-rmse:1.602495 test-rmse:275.897353 
## [49] train-rmse:1.399710 test-rmse:275.975064 
## [50] train-rmse:1.302365 test-rmse:275.976257 
## [51] train-rmse:1.174593 test-rmse:275.987551 
## [52] train-rmse:1.060106 test-rmse:276.027349 
## [53] train-rmse:0.962140 test-rmse:276.037280 
## [54] train-rmse:0.842934 test-rmse:276.029949 
## [55] train-rmse:0.790609 test-rmse:276.011626 
## [56] train-rmse:0.709991 test-rmse:275.967322 
## [57] train-rmse:0.605930 test-rmse:275.955910 
## [58] train-rmse:0.538187 test-rmse:275.943067 
## [59] train-rmse:0.460095 test-rmse:275.893464 
## [60] train-rmse:0.425276 test-rmse:275.893217 
## [61] train-rmse:0.387487 test-rmse:275.898908 
## [62] train-rmse:0.354226 test-rmse:275.881954 
## [63] train-rmse:0.326754 test-rmse:275.886063 
## [64] train-rmse:0.304253 test-rmse:275.886084 
## [65] train-rmse:0.284451 test-rmse:275.874050 
## [66] train-rmse:0.263457 test-rmse:275.884290 
## [67] train-rmse:0.245714 test-rmse:275.878927 
## [68] train-rmse:0.230607 test-rmse:275.880885 
## [69] train-rmse:0.214868 test-rmse:275.885406 
## [70] train-rmse:0.196878 test-rmse:275.887555

Comentário: Podemos reparar que o RMSE mínimo de teste foi atingido no round 13. Além desse ponto, o RMSE parece ficar crescendo o que pode ser um sinal de que estamos sobreajustando o banco de treinamento. Vamos usar então no nosso modelo final de XGboost 13 rounds.

# Definindo o modelo final

final = xgboost(data = xgb_train, max.depth = 3, nrounds = 13, verbose = 0)

Fazendo as predições

# Fazendo previsões
pred_mod <- predict(final, xgb_test , ntreelimit = 13)

## [00:09:23] WARNING: src/c_api/c_api.cc:935: `ntree_limit` is deprecated, use `iteration_range` instead.

Valores de taxas de crime preditos

predicao = cbind(obs = 1:12, preditos = pred_mod)

knitr::kable(predicao)

obs	preditos
1	541.2493
2	791.9097
3	797.4559
4	612.3510
5	921.8320
6	618.4196
7	1480.8826
8	751.7279
9	1439.6045
10	1507.3625
11	1044.2444
12	890.4138

c1) Fazendo a análise dos shapvalues do modelo calculado na letra b). {-} (1.75 pontos)

shape_values = shap.values(xgb_model  = final, X_train = xgb_train)
shape_values$mean_shap_score

##         police_exp60    nonwhites_per1000         unemploy_m39 
##           126.936141           109.765494            46.797984 
##          prob_prison labour_participation         police_exp59 
##            35.393480            26.614197            23.353982 
##         unemploy_m24                  gdp            percent_m 
##            19.472096            18.437931            17.498244 
##          time_prison            state_pop             is_south 
##            12.717063             2.169092             0.000000 
##       mean_education           m_per1000f           inequality 
##             0.000000             0.000000             0.000000

shape_values_crime = shape_values$shap_score

Exercício 2 (3,5 pontos)

Para esse exercício será utilizado o banco de dados BostonHousing do pacote mlbench do R. Imaginando que o objetivo seja prever a variável crim que indica a taxa de crimes per capta eu vou usar a técnica Lasso na seleção de variáveis e um banco de treinamento de \(70\)%.

require(mlbench)

## Carregando pacotes exigidos: mlbench

data("BostonHousing")

library(caret)
library(glmnet)

set.seed(00316695)


index <- createDataPartition(BostonHousing$crim, p = 0.7, list = FALSE)
train_data <- BostonHousing[index, ]
test_data <- BostonHousing[-index, ]

y_train <- train_data$crim
x_train <- as.matrix(train_data[, -1])

# Ajustando o modelo Lasso
crim_lasso <- glmnet(x = x_train, y = y_train, alpha = 1)

# Validando com 10-fold cross-validation
lasso_cv <- cv.glmnet(x = x_train, y = y_train, alpha = 1)

# Encontrando o valor de lambda ótimo
lambda_otm <- lasso_cv$lambda.min

# Ajustando o modelo Lasso com o valor de lambda ótimo
otm_lasso <- glmnet(x = x_train, y = y_train, alpha = 1, lambda = lambda_otm)

lbs_fun <- function(fit, ...) {
        L <- length(fit$lambda)
        x <- log(fit$lambda[L])
        y <- fit$beta[, L]
        labs <- names(y)
        text(x, y, labels = labs, cex = .5)
        legend('bottomright', legend=labs, col=1:length(labs), lty=1,
               cex = 0.6, ncol = 3) 
}

Acima foi aplicado o Método de seleção de variáveis Lasso a um banco de treinamento de \(70\%\) da proporção do banco de dados original, com validação cruzada 10-fold.

a2) Interprete os gráficos (2.2 pontos)

Aumento do parâmetro de tuning e coeficientes

{
plot(crim_lasso, xvar="lambda")
lbs_fun(crim_lasso)}

Visto que as variáveis que tendem a 0, de forma mais lenta, de acordo com o aumento do parâmetro de tuning \(\lambda\) são consideradas as variáveis mais importantes para explicar a variável resposta ( crim ). Embora seja difícil a visualização, temos que a variável rad é a mais importante do modelo para explicar a taxa de crimes per capita. Visto que a mesma foi a que atingiu o valor 0 lentamente com um maior valor de \(log({\lambda})\).

Aumento do parâmetro de tuning e EQM da validação cruzada 10 fold.

plot(lasso_cv)

O gráfico acima mostra o EQM da validação cruzada para diferentes valores de log(λ) . Os pontos vermelhos são as estimativas pontuais do EQM após realização da validação cruzada. As barras em cinza indicam o intervalo de confiança para o EQM, calculado através da validação cruzada. A linha pontilhada mais à esquerda indica o valor do parâmetro de tuning (log do parâmetro) que produziu um EQM mínimo, e a linha pontilhada à direita indica o valor do parâmetro de tuning cujo EQM está um desvio padrão acima do EQM mínimo obtido. Por fim, os números no topo do gráfico mostram a quantidade de coeficientes diferentes de zero para cada valor testado para o parâmetro de tuning. Pela posição da linha pontilhada mais à esquerda, percebe-se que o valor do parâmetro de tuning (log()) que produziu um valor de erro quadrático médio mínimo foi de aproximadamente \(log({\lambda}) = -2,8\).

b2) Qual o valor do parâmetro \(\lambda\) escolhido e qual as variáveis mais influentes no modelo. {-} (1.3 pontos)

library(dplyr)
otm_lasso

## 
## Call:  glmnet(x = x_train, y = y_train, alpha = 1, lambda = lambda_otm) 
## 
##   Df  %Dev  Lambda
## 1 11 45.07 0.05773

Pela saída do modelo acima, foi selecionado um \(\lambda = 0.05773\). Visto que este valor de \(\lambda\) minimiza o EQM na validação cruzada 10-fold. Também nota-se, por df (graus de liberdade), que 9 variáveis foram selecionadas como as mais influentes para a variável resposta.

otm_lasso %>% coef 

## 14 x 1 sparse Matrix of class "dgCMatrix"
##                      s0
## (Intercept) 14.26334628
## zn           0.03967774
## indus       -0.10607581
## chas        -0.32548249
## nox         -5.88454935
## rm           0.19710688
## age          .         
## dis         -0.79720869
## rad          0.50626606
## tax          .         
## ptratio     -0.08627554
## b           -0.01558726
## lstat        0.08926594
## medv        -0.15934935

Pela saída acima, as variáveis mais influentes, em ordem, são:

1. nox: concentração de óxido nítrico (ppm);
2. dis: distância ponderada de centros de emprego em Boston;
3. rad: índice de acessibilidade a rodovias radiais;
4. medv: valor mediano de casas ocupadas por proprietários por 1000 dólares;
5. lstat: porcentagem da população no menor status;
6. ptratio: taxa de aluno-professor por cidade;
7. indus: proporção de acres de negócios não varejistas por cidade;
8. zn: proporção de terras residenciais zonadas para lotes com mais de 25.000 pés quadrados;
9. b: \(1000(B-0.63)^2\) onde é a \(B\) proporção de pessoas pretas por cidade

Exercicio 3 (6 pontos)

Assim como a administração de empresas se preocupa com alocação de recursos, os times da National Basketball Association (NBA) também tentam avaliar a qualidade de jogadores quanto a diferentes habilidades.

Os jogadores da NBA são classificados em 5 posições pré-definidas:

• Point guard (armador): grande manipulador de bola (handler) e grande passador. Geralmente lideram a liga em número de assistências. Costumam converter alguns arremessos de longa distância;

• Shotting guard (off guard): grandes arremessadores de três pontos, os melhores defensores da equipe, e bons manipuladores de bola;

• Small foward: mais versátil das posições. Ótimos arremessadores de dois pontos, principalmente da linha de lance livre. Bons arremessadores de longa distância;

• Power foward (ala de fora): é frequentemente o marcador mais versátil da equipe. Marca pontos perto da cesta e em média distância;

• Center (pivô): são muito habilidosos em conseguir rebotes e realizar bloqueios (tocos).

Os dados do exercícios são referentes à atletas da NBA das últimas dez temporadas (2009-2010 a 2018-2019), considerando apenas os jogadores que jogaram em média mais do que 19.7 minutos (mediana dos minutos jogados). O banco de dados da NBA conta com 2868 observações e 21 variáveis.

library(tidyverse)
library(knitr)
library(sqldf)
library(DT)
library(ggplot2)
library(ggcorrplot)
library(GGally)
library(embed)
library(umap)
library(factoextra)
library(Hmisc)

nba = read.csv2("NBA DATASET.csv", header = T)
nba = nba[which(nba$min > median(nba$min)), ]
nba$fgperc = nba$fgm/nba$fga
nba$p3perc = nba$pm3/nba$pa3
nba$ftperc = nba$ftm/nba$fta
nba[is.na(nba)] = 0
head(nba)

##            player team position    season gp  min  pts fgm  fga pm3 pa3 ftm fta
## 4    Aaron Brooks  CHI    Guard 2014_2015 82 23.0 11.6 4.2 10.0 1.5 3.8 1.8 2.1
## 5    Aaron Gordon  ORL   Foward 2018_2019 78 33.8 16.0 6.0 13.4 1.6 4.4 2.4 3.2
## 6    Aaron Gordon  ORL   Foward 2017_2018 58 32.9 17.6 6.5 14.9 2.0 5.9 2.7 3.9
## 7    Aaron Gordon  ORL   Foward 2016_2017 80 28.7 12.7 4.9 10.8 1.0 3.3 2.0 2.7
## 8    Aaron Gordon  ORL   Foward 2015_2016 78 23.9  9.2 3.5  7.4 0.5 1.8 1.7 2.5
## 10 Aaron Harrison  DAL    Guard 2017_2018  9 25.9  6.7 2.1  7.7 1.0 4.8 1.4 1.9
##    oreb dreb ast stl blk    fgperc    p3perc    ftperc
## 4   0.4  1.6 3.2 0.7 0.2 0.4200000 0.3947368 0.8571429
## 5   1.7  5.7 3.7 0.7 0.7 0.4477612 0.3636364 0.7500000
## 6   1.5  6.4 2.3 1.0 0.8 0.4362416 0.3389831 0.6923077
## 7   1.5  3.6 1.9 0.8 0.5 0.4537037 0.3030303 0.7407407
## 8   2.0  4.5 1.6 0.8 0.7 0.4729730 0.2777778 0.6800000
## 10  0.4  2.2 1.2 1.0 0.2 0.2727273 0.2083333 0.7368421

As variáveis do banco de dados são:

Variável	Descrição
player	Nome do jogador
team	Time do jogador
position	Posição do jogador
season	Temporada das estatísticas
gp	Quantidade de partidas jogadas
min	Média de minutos jogados
pts	Média de pontos feitos
fgm	Média de arremessos de 2 pontos convertidos
fga	Média de tentativas de arremessos de 2 pontos
pm3	Média de arremessos de 3 pontos convertidos
pa3	Média de tentativas de arremessos de 3 pontos
ftm	Média de lances livres convertidos
fta	Média de tentativas de lances livres
oreb	Média de rebotes ofensivos
dreb	Média de rebotes defensivos
ast	Média de assistências
stl	Média de roubos de bola
blk	Média de bloqueios
fgperc	Proporção da média de arremessos de 2 pontos convertidos
p3perc	Proporção da média de arremessos de 3 pontos convertidos
ftperc	Proporção da média de lances livres convertidos

Para as análises será utilizada somente a temporada de 2018-2019 e as variáveis quantitativas.

---

Resultados

a3) Selecionando somente os jogadores da temporada e fazendo uma análise exploratória dos dados. (1 ponto)

Utilizando a linguagem sql para obter somente os jogadores da temporada 2018-2019

mydata3 = sqldf::sqldf('select*
                          from nba
                            where season in("2018_2019")' ) 



# Selecionando as variáveis quantitativas
mydata3 = mydata3 %>% 
            select(-c(1,2,3,4)) %>% 
              round(4)

Overview do banco depois de limpeza dos dados

mydata3 %>% 
    DT::datatable()

Análise Exploratória dos dados

Nomes das variáveis no banco obtido

Variavel = names(mydata3)
Descrição = c( "Quantidade de partidas jogadas", "Média de minutos jogados", "Média de pontos feitos", "Média de arremessos de 2 pontos convertidos", "Média de tentativas de arremessos de 2 pontos", "Média de arremessos de 3 pontos convertidos", "Média de tentativas de arremessos de 3 pontos", "Média de lances livres convertidos", "Média de tentativas de lances livres", "Média de rebotes ofensivos", "Média de rebotes defensivos", "Média de assistências", "Média de roubos de bola", "Média de bloqueios", "Proporção da média de arremessos de 2 pontos convertidos", "Proporção da média de arremessos de 3 pontos convertidos", "Proporção da média de lances livres convertidos")

tabela = cbind(Variavel, Descrição)
names(tabela) = c("Variável", "Label")
knitr::kable(tabela)

Variavel	Descrição
gp	Quantidade de partidas jogadas
min	Média de minutos jogados
pts	Média de pontos feitos
fgm	Média de arremessos de 2 pontos convertidos
fga	Média de tentativas de arremessos de 2 pontos
pm3	Média de arremessos de 3 pontos convertidos
pa3	Média de tentativas de arremessos de 3 pontos
ftm	Média de lances livres convertidos
fta	Média de tentativas de lances livres
oreb	Média de rebotes ofensivos
dreb	Média de rebotes defensivos
ast	Média de assistências
stl	Média de roubos de bola
blk	Média de bloqueios
fgperc	Proporção da média de arremessos de 2 pontos convertidos
p3perc	Proporção da média de arremessos de 3 pontos convertidos
ftperc	Proporção da média de lances livres convertidos

Estrutura do banco de dados

str(mydata3)

## 'data.frame':    295 obs. of  17 variables:
##  $ gp    : num  78 68 68 64 25 77 81 43 43 64 ...
##  $ min   : num  33.8 29 29 21.5 21.2 20.1 28.3 26.4 26.4 22.8 ...
##  $ pts   : num  16 13.6 13.6 8.8 9.2 11.1 9.4 9.6 9.6 10.9 ...
##  $ fgm   : num  6 5.7 5.7 3 3.1 4.2 3.2 3.2 3.2 3.6 ...
##  $ fga   : num  13.4 10.6 10.6 7.4 6.9 8.4 7.3 8.7 8.7 8.1 ...
##  $ pm3   : num  1.6 1.1 1.1 1 1 1 1.2 2.3 2.3 0.8 ...
##  $ pa3   : num  4.4 3 3 2.6 2 2.6 3.5 6 6 2.1 ...
##  $ ftm   : num  2.4 1.1 1.1 1.8 2 1.8 1.9 1 1 2.8 ...
##  $ fta   : num  3.2 1.4 1.4 2.2 2.6 2.8 2.1 1.3 1.3 3.5 ...
##  $ oreb  : num  1.7 1.8 1.8 0.5 0.8 2.1 1.4 0.4 0.4 0.5 ...
##  $ dreb  : num  5.7 5 5 3.2 1.9 3.5 6.1 3.1 3.1 2.6 ...
##  $ ast   : num  3.7 4.2 4.2 2 3.1 1.1 1.3 1.1 1.1 1.9 ...
##  $ stl   : num  0.7 0.9 0.9 0.6 1 0.4 0.8 0.5 0.5 0.4 ...
##  $ blk   : num  0.7 1.3 1.3 0.3 0.4 0.9 0.4 0.3 0.3 0.2 ...
##  $ fgperc: num  0.448 0.538 0.538 0.405 0.449 ...
##  $ p3perc: num  0.364 0.367 0.367 0.385 0.5 ...
##  $ ftperc: num  0.75 0.786 0.786 0.818 0.769 ...

Comentário: Todas as variáveis do banco obtido são numéricas.

Detecção de missing data (dados faltantes) ???

missings_vector = sapply(mydata3, function(x) sum(is.na(mydata3)))

print(missings_vector)

##     gp    min    pts    fgm    fga    pm3    pa3    ftm    fta   oreb   dreb 
##      0      0      0      0      0      0      0      0      0      0      0 
##    ast    stl    blk fgperc p3perc ftperc 
##      0      0      0      0      0      0

Comentário: Não tem presença de nenhum dado faltante no banco obtido.

> Descritivas do banco de dados

standard_desviation = numeric(0)
variance = numeric(0)
min_var = numeric(0)
max_var = numeric(0)
mediana_var = numeric(0)
media_var = numeric(0)

for (i in (1:17)){
  
  standard_desviation = append(standard_desviation, sd(mydata3[,i]))
  variance = append(variance, var(mydata3[,i]))
  min_var = append(min_var, min(mydata3[,i]))
  max_var = append(max_var, max(mydata3[,i]))
  mediana_var = append(mediana_var, median(mydata3[,i]))
  media_var = append(media_var, mean(mydata3[,i]))}



Desvio_padrao = standard_desviation
Variancia = variance
Minimo = min_var
Maximo = max_var
Mediana = mediana_var
Media = media_var

banco_summary = rbind(Desvio_padrao, Variancia, Minimo, Maximo, Mediana, Media)


rownames(banco_summary) = c("Desvio_Padrão", "Variância", "Mínimo", "Máximo", "Mediana", "Média")

colnames(banco_summary) = names(mydata3)

banco_summary =  banco_summary %>% round(2)

knitr::kable (banco_summary)

	gp	min	pts	fgm	fga	pm3	pa3	ftm	fta	oreb	dreb	ast	stl	blk	fgperc	p3perc	ftperc
Desvio_Padrão	17.21	4.52	5.53	1.97	3.99	0.85	2.19	1.51	1.88	0.92	1.92	1.90	0.37	0.49	0.06	0.10	0.09
Variância	296.12	20.41	30.61	3.87	15.96	0.72	4.80	2.29	3.52	0.85	3.69	3.60	0.14	0.24	0.00	0.01	0.01
Mínimo	1.00	19.80	4.30	1.50	4.00	0.00	0.00	0.20	0.30	0.00	1.40	0.40	0.10	0.00	0.33	0.00	0.40
Máximo	82.00	36.90	36.10	10.80	24.50	5.10	13.20	9.70	11.00	5.40	11.10	10.70	2.20	2.70	0.70	0.50	0.92
Mediana	71.00	27.30	12.00	4.40	9.80	1.20	3.60	1.80	2.40	0.90	3.50	2.30	0.80	0.40	0.45	0.35	0.78
Média	65.63	27.52	13.26	4.88	10.55	1.34	3.75	2.15	2.80	1.16	4.05	2.93	0.89	0.57	0.46	0.32	0.77

Comentário: Podemos observar a partir da análise descritiva dos dados que tem uma maior variância entre os jogadores da temporada 2018-2019 da NBA especificamente na quantidade de partidas jogadas. Além disso, em média quase 66 partidas foram jogadas por jogador da temporada e o mínimo de partidas jogadas foi de 1 (uma) partida. Uma possível explicação poderia ser que o jogador que jogou essa única partida na temporada não era suficientemente bom para jogar mais partidas ou talvez se machucou durante a temporada.

Histograma de cada variável

# Histograma
for (i in (1:17)){

  hist(mydata3[, i], col = "blue", xlab = names(mydata3)[i],  main = paste0("Histograma da variável", " ",  names(mydata3)[i]))

}

Comentário: Nenhuma variável exibiu uma distribuição normal. A maioria das variáveis do banco apresentaram uma distribuição assimétrica à direita.

Boxplot olhando as variáveis conjuntamente

# Boxplot

boxplot(mydata3, col = "blue", main = "Overview do Boxplot de todas as variáveis do banco" )

Comentário: Como esperado a variável que apresentou uma maior variância foi a Quantidade de partidas jogadas. Essa variável se destacou de todas as outras por seu comportamento. As duas outras que tentaram se destacar também são a Média de pontos feitos seguida pela Média de minutos jogados. Talvez poderia se olhar mais essas variáveis para separar os jogadores da temporada.

Correlação entre as variáveis do banco obtido

ggpairs(mydata3, aes(alpha=0.5), lower=list(continuous="points"),
        upper=list(continuous="blank"),
        axisLabels="none", switch="both")

ggcorrplot::ggcorrplot(cor(mydata3),
                       hc.order = TRUE,
                       type = "lower",
                       lab = TRUE,
                       lab_size = 2.5) 

Comentário: É importante ressaltar que obtivemos uma correlação linear muito forte (0,98) entre a Média de pontos feitos e a Média de arremessos de 2 pontos convertidos, entre a Média de lances livres convertidos e a Média de tentativas de lances livres e finalmente entre a Média de arremessos de 3 pontos convertidos e a Média de tentativas de arremessos de 3 pontos o que faz sentido com a realidade. Porém teve variáveis que parecem não ter uma boa relação linear. As variáveis Média de rebotes defensivos e Quantidade de partidas jogadas por exemplo, são o par perfeito de uma relação não linear

b3) Aplicando algum método de redução de dimensionalidade a esse banco de dados e interpretando os resultados encontrados. (2.5 pontos)

Redução de dimensionalidade com a técnica UMAP depois de padronização das variáveis

Observação: Foi escolhida a técnica UMAP neste caso porque parece que tem variáveis que não têm uma relação linear

# UMAP com variáveis colocadas na mesma escala


set.seed(00316695)
umap_fit <- mydata3 %>%
  select(where(is.numeric)) %>%
  scale() %>% 
  umap()

umap_fit



umap_df <- umap_fit$layout %>%
  as.data.frame() %>% 
  round(5)
 


DT::datatable(umap_df)

Interpretação: Inicialmente tinhamos 17 variáveis mas o método UMAP retornou duas variáveis que são combinações das variáveis originais. É importante salientar que as variáveis foram padronizadas antes de aplicar o método UMAP.

c3) Aplicando um método de clusterização à esse banco de dados e interpretando os resultados. (2.5 pontos)

Clusterização do banco de dados:

fviz_nbclust(umap_df, kmeans,method = "silhouette", linecolor = "red")

Interpretação: Olhando o gráfico acima parece que seria melhor agrupar os dados em exatamente 9 clusters (grupos). A localização da curva (joelho/cotovelo) na plotagem é geralmente considerada como um indicador do número apropriado de agrupamentos. A função R fviz_nbclust() parece fornecer uma solução conveniente para estimar o número ideal de clusters.

Visualização dos dados clusterizados:

set.seed(00316695)
dataKmeans <- kmeans(umap_df,9)


clusterized <- fviz_cluster(dataKmeans,
 data = umap_df, 
 geom = "point",
 stand = FALSE,
 title = "kMEANS — CLUSTERING",
 frame.type = "convex")

clusterized

my_clusters= (data.frame(Clusters = 1:9, dataKmeans$centers))   %>% round(3)
names(my_clusters) = c("Clusters", "Variável1", "Variável2")

knitr::kable((my_clusters) %>% dplyr::arrange(my_clusters[2]))

	Clusters	Variável1	Variável2
2	2	-3.247	-1.006
7	7	-1.964	2.264
9	9	-1.528	0.275
5	5	-0.006	1.788
4	4	0.526	-0.981
3	3	0.810	-3.350
1	1	1.747	1.150
6	6	2.951	-1.970
8	8	3.634	1.571

Interpretação a partir dos centróides dos clusters:

Olhando as características dos centróides dos 9 (nove) clusters (grupos) acima e o gráfico dos dados clusterizados, podemos dizer que em média o grupo que possui características acima da média olhando as duas variáveis conjuntamente é o grupo 8 enquanto o grupo 2 é aquele que apresentou características abaixo da média de novo olhando conjuntamente as duas variáveis. Além disso, o grupo 8 olhando o gráfico dos dados clusterizados parece ter menos jogadores que o grupo 2.

Infelizmente a dimensão do banco original foi bem reduzida, mas seria mais interessante olhar a formação dos clusters em função de todas as variáveis íniciais para poder tomar decições que podem trazer talvez resultados positivos para os jogadores e portanto para os times da NBA.