Importação de Bibliotecas
library(readr)
library(tidyverse)
library(factoextra)
library(cluster)
library(gargle)
library(bigrquery)
library(lubridate)
library(caret)
library(mlr)
library(rcompanion)
library(DescTools)
library(xgboost)O arquivo disponibilizado foi aberto no excel, tratando a questão de codificação e a separação por vírgulas. E assim foi criado o “base_desafio_cartola2.csv”.
Para essa análise, primeiro será realizado o tratamento de dados e uma análise exploratória, todas com o objetivo de entender o perfil de consumo dos assinantes cartolas PRO.
Extração dos Dados
## Extração dos Dados
base_desafio_cartola <- read_csv("base_desafio_cartola2.csv",
col_types = cols(user = col_character()),
na= "NA")Após a extração de dados, iremos avaliar as informações presentes na base de dados, inconsistências e a completude de cada uma das variáveis.
Tratamento e Completude dos Dados
## user sexo uf idade
## Length:50689 Length:50689 Length:50689 Min. :-7161.00
## Class :character Class :character Class :character 1st Qu.: 22.00
## Mode :character Mode :character Mode :character Median : 27.00
## Mean : 29.31
## 3rd Qu.: 35.00
## Max. : 236.00
## NA's :28073
## dias pviews visitas tempo_total
## Min. : 1.000 Min. : 1.00 Min. : 1.00 Min. : 45
## 1st Qu.: 2.000 1st Qu.: 4.00 1st Qu.: 2.00 1st Qu.: 180
## Median : 5.000 Median : 15.00 Median : 7.00 Median : 1672
## Mean : 8.538 Mean : 56.69 Mean : 17.15 Mean : 12637
## 3rd Qu.:13.000 3rd Qu.: 58.00 3rd Qu.: 21.00 3rd Qu.: 10349
## Max. :31.000 Max. :2143.00 Max. :277.00 Max. :225691
##
## device futebol futebol_intenacional futebol_olimpico
## Length:50689 Min. : 0 Min. : 0 Min. : 0.0
## Class :character 1st Qu.: 0 1st Qu.: 0 1st Qu.: 0.0
## Mode :character Median : 135 Median : 0 Median : 0.0
## Mean : 3938 Mean : 274 Mean : 1156.3
## 3rd Qu.: 2366 3rd Qu.: 0 3rd Qu.: 209.9
## Max. :187225 Max. :161337 Max. :176608.4
##
## blog_cartola atletismo ginastica judo
## Min. : 0.0 Min. : 0.00 Min. : 0.0 Min. : 0.0
## 1st Qu.: 0.0 1st Qu.: 0.00 1st Qu.: 0.0 1st Qu.: 0.0
## Median : 0.0 Median : 0.00 Median : 0.0 Median : 0.0
## Mean : 822.9 Mean : 347.24 Mean : 312.7 Mean : 340.6
## 3rd Qu.: 199.0 3rd Qu.: 8.07 3rd Qu.: 0.0 3rd Qu.: 0.0
## Max. :196982.9 Max. :104413.66 Max. :144959.7 Max. :94089.6
##
## natacao basquete handebol volei
## Min. : 0.0 Min. : 0.0 Min. : 0.0 Min. : 0.0
## 1st Qu.: 0.0 1st Qu.: 0.0 1st Qu.: 0.0 1st Qu.: 0.0
## Median : 0.0 Median : 0.0 Median : 0.0 Median : 0.0
## Mean : 297.4 Mean : 282.9 Mean : 251.8 Mean : 230.4
## 3rd Qu.: 0.0 3rd Qu.: 0.0 3rd Qu.: 0.0 3rd Qu.: 0.0
## Max. :170804.7 Max. :115990.7 Max. :104274.2 Max. :90985.2
##
## tenis canoagem saltos_ornamentais home
## Min. : 0.0 Min. : 0.0 Min. : 0.0 Min. : 0.00
## 1st Qu.: 0.0 1st Qu.: 0.0 1st Qu.: 0.0 1st Qu.: 0.00
## Median : 0.0 Median : 0.0 Median : 0.0 Median : 13.57
## Mean : 138.5 Mean : 141.1 Mean : 114.7 Mean : 1931.81
## 3rd Qu.: 0.0 3rd Qu.: 0.0 3rd Qu.: 0.0 3rd Qu.: 569.67
## Max. :84894.9 Max. :106953.5 Max. :84184.8 Max. :192745.56
##
## home_olimpiadas cartola_status
## Min. : 0.0 Length:50689
## 1st Qu.: 0.0 Class :character
## Median : 0.0 Mode :character
## Mean : 650.8
## 3rd Qu.: 129.1
## Max. :101053.6
## ## Tratamento da Variável Idade
base_desafio_cartola$idade = ifelse(base_desafio_cartola$idade<10 | base_desafio_cartola$idade>=100, NA,base_desafio_cartola$idade )
## Análise de Completude de todas as variáveis da base
vetor = c()
for(i in 1:ncol(base_desafio_cartola)){
vetor = c(vetor,sum(is.na(base_desafio_cartola[,i])))
}
names(vetor) <-colnames(base_desafio_cartola)
completude = 1-(vetor/nrow(base_desafio_cartola))Ao verificar que existiam usuários com idades menores que 10 e maiores que 100, optou-se por não seguir com essas informações, de forma que, passou a ser considerada desconhecida, para esses usuários. O código acima transforma a variável idade em vazio.
Análise Exploratória
Para começar a análise exploratória, foram analisados os perfis demográficos dos assinantes Cartola Pro e não assinantes PRO.
Gênero
### ANÁLISE DESCRITIVA
Genero = base_desafio_cartola %>% select(sexo, cartola_status) %>% group_by(sexo, cartola_status) %>% summarise(Pessoas = n()) %>% na.omit()
Genero_PRO = Genero %>% filter(cartola_status == "Cartola Pro") %>% mutate(freq = Pessoas/811)
Genero_Free = Genero %>% filter(cartola_status != "Cartola Pro") %>% mutate(freq = Pessoas/14707)
### TESTE DE HIPÓTESES
base_teste_Genero = base_desafio_cartola %>% na.omit() %>% select(cartola_status, sexo)
chisq.test(table(base_teste_Genero$cartola_status, base_teste_Genero$sexo))##
## Pearson's Chi-squared test with Yates' continuity correction
##
## data: table(base_teste_Genero$cartola_status, base_teste_Genero$sexo)
## X-squared = 7.5365, df = 1, p-value = 0.006046##
## 2-sample test for equality of proportions with continuity correction
##
## data: c(791, 13998) out of c(811, 14707)
## X-squared = 9.0005, df = 1, p-value = 0.00135
## alternative hypothesis: greater
## 95 percent confidence interval:
## 0.01347977 1.00000000
## sample estimates:
## prop 1 prop 2
## 0.9753391 0.9517917##
## 2-sample test for equality of proportions with continuity correction
##
## data: c(20, 709) out of c(811, 14707)
## X-squared = 9.0005, df = 1, p-value = 0.00135
## alternative hypothesis: less
## 95 percent confidence interval:
## -1.00000000 -0.01347977
## sample estimates:
## prop 1 prop 2
## 0.02466091 0.04820834Através dos testes de hipóteses, notou-se que, mesmo que ambos os grupos sejam majoritariamente masculinos, a diferença é estatísticamente significante. Ou seja, os assinantes PRO tem uma proporção maior de homens.
Idade
Faixa_Etaria_b = base_desafio_cartola %>% select(idade, cartola_status) %>% filter(cartola_status == "Cartola Pro") %>%
mutate(Faixa_Etaria = ifelse(idade<=17,"Ate 17 anos",
ifelse(idade<=24, "18 a 24 anos",
ifelse(idade<=34,"25 a 34 anos",
ifelse(idade<=49, "35 a 49 anos",
"+50 anos"))))) %>% select(Faixa_Etaria) %>% na.omit() %>% group_by(Faixa_Etaria) %>% summarise(Pessoas = n()) %>% mutate(Freq = Pessoas/sum(Pessoas))
### Número Análise Descritiva
Idade = base_desafio_cartola %>% select(idade, cartola_status) %>% group_by(cartola_status) %>% summarise(idade = mean(idade, na.rm=T)) %>% na.omit()
Idade_PRO = base_desafio_cartola %>% select(idade, cartola_status) %>% filter(cartola_status == "Cartola Pro") %>% na.omit
#hist(Idade_PRO$idade)
Idade_Free = base_desafio_cartola %>% select(idade, cartola_status) %>% filter(cartola_status == "Cartola Free") %>% na.omit
#hist(Idade_Free$idade)
### Teste de Hipóteses
t.test(Idade_PRO$idade, Idade_Free$idade, alternative = "greater") # teste considerando que os dados seguem uma distribuição normal##
## Welch Two Sample t-test
##
## data: Idade_PRO$idade and Idade_Free$idade
## t = 10.254, df = 910.09, p-value < 2.2e-16
## alternative hypothesis: true difference in means is greater than 0
## 95 percent confidence interval:
## 2.67981 Inf
## sample estimates:
## mean of x mean of y
## 30.26895 27.07649wilcox.test(Idade_PRO$idade, Idade_Free$idade, alternative = "greater") # teste não paramétrica, sem pressuposto de distribuição##
## Wilcoxon rank sum test with continuity correction
##
## data: Idade_PRO$idade and Idade_Free$idade
## W = 7493474, p-value < 2.2e-16
## alternative hypothesis: true location shift is greater than 0set.seed(1)
grupo1<-data.frame(valor=Idade_PRO$idade, grupo="Cartoleiro Pro")
grupo2<-data.frame(valor=Idade_Free$idade, grupo="Não Cartoleiro Pro")
ggplot(grupo2,aes(valor, fill=grupo)) +
geom_histogram(alpha = 0.5, position = 'identity',binwidth = 1,fill="orange")+
geom_histogram(data=grupo1,alpha = 0.5, position = 'identity',binwidth = 2,fill="yellow") + theme_classic()
Através dos testes de hipóteses, notou-se que, a média da idade dos cartoleiros PRO é superior a média da idade dos não assinantes PRO.
Região
### Criação da Variável
base_desafio_cartola$regiao = ifelse(base_desafio_cartola$uf %in% c("Rio de Janeiro","Sao Paulo","Espirito Santo","Minas Gerais"), "Sudeste",
ifelse(base_desafio_cartola$uf %in% c("Acre","Roraima","Rondonia","Para","Amazonas","Amapa"), "Norte",
ifelse(base_desafio_cartola$uf %in% c("Ceara","Maranhao","Bahia","Pernambuco","Piaui","Rio Grande do Norte","Sergipe","Alagoas","Paraiba"), "Nordeste",
ifelse(base_desafio_cartola$uf %in% c("Parana","Rio Grande do Sul","Santa Catarina"), "Sul",
ifelse(base_desafio_cartola$uf %in% c("Distrito Federal","Mato Grosso","Mato Grosso do Sul","Goias","Tocantins"), "Centro-Oeste",base_desafio_cartola$uf
)))))
### Número Análise Descritiva
Regiao_PRO = base_desafio_cartola %>% filter(cartola_status == "Cartola Pro") %>% select(regiao) %>%
group_by(regiao) %>% summarise(Pessoas = n()) %>% na.omit() %>% mutate(Freq = Pessoas/sum(Pessoas))
Regiao_Free = base_desafio_cartola %>% filter(cartola_status == "Cartola Free") %>% select(regiao) %>%
group_by(regiao) %>% summarise(Pessoas = n()) %>% na.omit() %>% mutate(Freq = Pessoas/sum(Pessoas))
### Teste de Hipóteses
regioes = c("Centro-Oeste","Nordeste","Norte", "Sudeste","Sul")
p_valores = c()
for(i in 1:length(regioes)){
t = prop.test(x = c(Regiao_PRO[Regiao_PRO$regiao == regioes[i],]$Pessoas,Regiao_Free[Regiao_Free$regiao == regioes[i],]$Pessoas), n = c(sum(Regiao_PRO$Pessoas),sum(Regiao_Free$Pessoas)), alternative = "greater")
p_valores = c(p_valores,t$p.value)
}
names(p_valores) = regioes
p_valores## Centro-Oeste Nordeste Norte Sudeste Sul
## 0.008832837 0.988485192 0.009241528 0.701485936 0.343775385A proporção de assinantes PRO é superior no Norte e no Centro-Oeste, mas inferior no Nordeste. Sudeste e Sul não apresentaram diferenças estatísticamente significantes.
Análise de consumo de modalidades - Top Modalidades
MODALIDADES = base_desafio_cartola %>% filter(cartola_status == "Cartola Pro") %>% select(futebol,futebol_intenacional,futebol_olimpico,blog_cartola,atletismo,ginastica,judo,natacao,basquete,handebol,volei,tenis,canoagem,saltos_ornamentais,home,home_olimpiadas)%>%
dplyr::mutate_if( is.numeric, sum) %>% distinct()
(TOP_CONSUMO = data.frame(Paginas = colnames(MODALIDADES), Consumo = MODALIDADES %>% as.numeric() ))## Paginas Consumo
## 1 futebol 11256021.0
## 2 futebol_intenacional 451817.2
## 3 futebol_olimpico 1788207.7
## 4 blog_cartola 3445138.0
## 5 atletismo 556412.5
## 6 ginastica 520915.9
## 7 judo 620895.3
## 8 natacao 653437.4
## 9 basquete 577742.5
## 10 handebol 374191.1
## 11 volei 235985.1
## 12 tenis 256028.6
## 13 canoagem 209973.3
## 14 saltos_ornamentais 205162.3
## 15 home 4653476.2
## 16 home_olimpiadas 1067227.0MODELAGEM
Tratamento de Dados
#Tratamento de Dados
# Criação da Variável Resposta
base_modelo = base_desafio_cartola %>% filter(!is.na(cartola_status)) %>% mutate(Assinante_PRO = ifelse(cartola_status == "Cartola Pro","Sim","Não")) %>% select(-user,-cartola_status,-uf)
## transformar variáveis qualitativas em fator
base_modelo = dplyr::mutate_if(base_modelo, is.character, as.factor)
## distribuição da variável resposta
prop.table(table(base_modelo$Assinante_PRO))##
## Não Sim
## 0.96679206 0.03320794Divisão entre Treino e Teste
Para a divisão da base em treino e teste, optou por dividir na proporção 75%/25%, mantendo a proporção da variável resposta iguais nas duas amostras:
set.seed(217054078)
sorteio <- createDataPartition(y=base_modelo$Assinante_PRO,p=0.75,list=F)
amostra_treino <- base_modelo[sorteio,]
amostra_teste <- base_modelo[-sorteio,]
prop.table(table(amostra_treino$Assinante_PRO))##
## Não Sim
## 0.96678314 0.03321686##
## Não Sim
## 0.9668188 0.0331812Pré-Processamento dos Dados:
Balanceamento dos Dados
Para realizar o balanceamento dos dados, utilizou-se a técnica Smote, gerando amostras artificais de usuários que são assinantes PRO, baseado nas distribuições das informações disponíveis.
library("DMwR")
BASE_MODELO_NEW <- SMOTE(Assinante_PRO~.-cartola_express-user, as.data.frame(amostra_treino), perc.over = 5000, perc.under = 0)
amostra_treino = rbind(amostra_treino ,BASE_MODELO_NEW )
prop.table(table(amostra_treino$Assinante_PRO))##
## Não Sim
## 0.3588574 0.6411426Imputação de valores faltantes
Após o balanceamento, foi realizada imputação dos dados faltantes. Para isso, foi utilizado o método de árvores de decisão para imputar tanto variáveis quantitativas quanto qualitativas.
### Imputação de variáveis quantitativas e categóricas:
#PARA TRATAR O PROBLEMA DE BAIXA COMPLETUDE DOS DADOS, FOI REALIZADA A IMPUTAÇÃO DE DADOS FALTANTES PRESENTES NA BASE DE DADOS. PARA ISSO, FOI UTILIZADO O MÉTODO DE ÁRVORES DE DECISÃO BASEADO NOS DADOS DE ASSINANTES E NÃO ASSINANTES PRO, PARA IMPUTAR TANTO DADOS QUANTITATIVOS QUANTO QUALITATIVOS.
im.met1 <- imputeLearner("classif.rpart")
im.met2 <- imputeLearner("regr.rpart")
set.seed(217054078)
dados_prep = mlr::impute(data.frame(amostra_treino),target="Assinante_PRO",
classes = list(factor=im.met1,
numeric=im.met2))
preproc_NA <- dados_prep$desc
dados_prep = dados_prep$data
amostra_treino = dados_prepAvaliação de Correlação, Variância Quase Zero, Combinação Linear e criação das variáveis Dummy
## freqRatio percentUnique zeroVar nzv
## sexo 72.139509 0.003051898 FALSE TRUE
## idade 1.569740 8.832191415 FALSE FALSE
## dias 1.533535 59.708848977 FALSE FALSE
## pviews 1.071508 62.168678376 FALSE FALSE
## visitas 1.552531 60.693085926 FALSE FALSE
## tempo_total 2.548090 93.267514077 FALSE FALSE
## device 2.086080 0.004577846 FALSE FALSE
## futebol 2.688605 81.954129980 FALSE FALSE
## futebol_intenacional 31.631692 29.162406726 FALSE FALSE
## futebol_olimpico 9.924090 54.923473670 FALSE FALSE
## blog_cartola 4.749890 76.634672608 FALSE FALSE
## atletismo 35.073276 35.170066989 FALSE FALSE
## ginastica 27.397237 48.950910228 FALSE FALSE
## judo 27.852624 38.122777837 FALSE FALSE
## natacao 23.783163 39.914241680 FALSE FALSE
## basquete 44.718238 31.185814780 FALSE FALSE
## handebol 32.067568 35.989501473 FALSE FALSE
## volei 38.336547 30.787542154 FALSE FALSE
## tenis 56.009479 26.081516183 FALSE FALSE
## canoagem 85.574468 12.709627211 FALSE FALSE
## saltos_ornamentais 47.105446 36.158881785 FALSE FALSE
## home 17.699225 80.179451574 FALSE FALSE
## home_olimpiadas 13.139172 66.714479728 FALSE FALSE
## regiao 5.181527 0.009155693 FALSE FALSE
## Assinante_PRO 1.786622 0.003051898 FALSE FALSE#amostra_treino = amostra_treino %>% select(-saltos_ornamentais)
### Correlação Variáveis Quantitativas
amostra_treino_qt = amostra_treino %>% select(idade,dias,pviews
,visitas
,tempo_total
,futebol,futebol_intenacional,futebol_olimpico,blog_cartola,atletismo,ginastica,judo,natacao,basquete,handebol,volei,tenis,canoagem,home,saltos_ornamentais,
home_olimpiadas)
descrCor<-cor(amostra_treino_qt, method="spearman")
descrCor## idade dias pviews visitas tempo_total
## idade 1.00000000 0.1490490 0.1886028 0.1766864 0.2193430
## dias 0.14904902 1.0000000 0.9206871 0.9750350 0.8547379
## pviews 0.18860284 0.9206871 1.0000000 0.9479351 0.9395046
## visitas 0.17668642 0.9750350 0.9479351 1.0000000 0.8878149
## tempo_total 0.21934304 0.8547379 0.9395046 0.8878149 1.0000000
## futebol 0.18002761 0.7792217 0.8719911 0.8141049 0.8831968
## futebol_intenacional 0.10125860 0.4649351 0.5264091 0.4886908 0.5284240
## futebol_olimpico 0.18144315 0.5993525 0.6609855 0.6219869 0.6858306
## blog_cartola 0.06794873 0.4372648 0.4803244 0.4320030 0.4471146
## atletismo 0.15139346 0.4791615 0.4756444 0.4921582 0.4963512
## ginastica 0.41438777 0.3585325 0.4006346 0.3989039 0.4436314
## judo 0.56455386 0.3705111 0.4316148 0.4238276 0.4778576
## natacao 0.34653199 0.3525826 0.4012277 0.3755417 0.4479035
## basquete 0.14929315 0.4540447 0.4653368 0.4727350 0.4817403
## handebol 0.08842679 0.4239696 0.4532543 0.4222528 0.4554723
## volei 0.11355578 0.4546136 0.4439067 0.4678730 0.4372888
## tenis 0.27234567 0.4267566 0.4612713 0.4752825 0.4849382
## canoagem 0.18339576 0.3229881 0.3647947 0.3477861 0.3832349
## home 0.16412348 0.6692593 0.7818947 0.7031741 0.7510740
## saltos_ornamentais 0.08374999 0.4101848 0.4057950 0.4039684 0.4014424
## home_olimpiadas 0.15160828 0.6370551 0.6647240 0.6551574 0.6628204
## futebol futebol_intenacional futebol_olimpico
## idade 0.1800276 0.1012586 0.1814432
## dias 0.7792217 0.4649351 0.5993525
## pviews 0.8719911 0.5264091 0.6609855
## visitas 0.8141049 0.4886908 0.6219869
## tempo_total 0.8831968 0.5284240 0.6858306
## futebol 1.0000000 0.4753312 0.6199203
## futebol_intenacional 0.4753312 1.0000000 0.4846228
## futebol_olimpico 0.6199203 0.4846228 1.0000000
## blog_cartola 0.3532415 0.1747097 0.2474591
## atletismo 0.3411492 0.3510326 0.3990300
## ginastica 0.3343493 0.2738464 0.3313174
## judo 0.4152837 0.3160311 0.4297053
## natacao 0.2933956 0.3557046 0.3580370
## basquete 0.3319489 0.3806914 0.4055775
## handebol 0.3525646 0.3107976 0.4972502
## volei 0.3027359 0.3267793 0.3570130
## tenis 0.4537137 0.3102043 0.4394000
## canoagem 0.2916415 0.3032884 0.3781247
## home 0.7230650 0.4587482 0.5921329
## saltos_ornamentais 0.2959179 0.2628922 0.3997894
## home_olimpiadas 0.5436195 0.4108400 0.5977142
## blog_cartola atletismo ginastica judo natacao
## idade 0.06794873 0.15139346 0.41438777 0.56455386 0.34653199
## dias 0.43726481 0.47916151 0.35853248 0.37051110 0.35258263
## pviews 0.48032439 0.47564436 0.40063458 0.43161477 0.40122771
## visitas 0.43200297 0.49215822 0.39890385 0.42382755 0.37554168
## tempo_total 0.44711461 0.49635120 0.44363136 0.47785765 0.44790348
## futebol 0.35324147 0.34114925 0.33434926 0.41528372 0.29339560
## futebol_intenacional 0.17470972 0.35103265 0.27384636 0.31603114 0.35570463
## futebol_olimpico 0.24745910 0.39903003 0.33131736 0.42970534 0.35803700
## blog_cartola 1.00000000 0.08492251 0.03504939 0.07458345 0.07710578
## atletismo 0.08492251 1.00000000 0.49593958 0.31178674 0.59397268
## ginastica 0.03504939 0.49593958 1.00000000 0.64292755 0.68620094
## judo 0.07458345 0.31178674 0.64292755 1.00000000 0.51493434
## natacao 0.07710578 0.59397268 0.68620094 0.51493434 1.00000000
## basquete 0.11091946 0.68220162 0.46206445 0.32502072 0.57493959
## handebol 0.19569116 0.52386932 0.30583551 0.20991462 0.42564109
## volei 0.09443250 0.67425339 0.42901348 0.23684296 0.51014543
## tenis 0.08954490 0.32321266 0.43074854 0.57528567 0.32146786
## canoagem 0.09530284 0.40680161 0.32060148 0.36603063 0.40659703
## home 0.31056204 0.31278226 0.34468324 0.40389792 0.32630665
## saltos_ornamentais 0.14427119 0.62530621 0.35011750 0.16381880 0.45637637
## home_olimpiadas 0.22105036 0.65956905 0.43989985 0.36854886 0.49065804
## basquete handebol volei tenis canoagem
## idade 0.1492931 0.08842679 0.1135558 0.2723457 0.18339576
## dias 0.4540447 0.42396963 0.4546136 0.4267566 0.32298811
## pviews 0.4653368 0.45325430 0.4439067 0.4612713 0.36479468
## visitas 0.4727350 0.42225281 0.4678730 0.4752825 0.34778615
## tempo_total 0.4817403 0.45547232 0.4372888 0.4849382 0.38323494
## futebol 0.3319489 0.35256459 0.3027359 0.4537137 0.29164150
## futebol_intenacional 0.3806914 0.31079759 0.3267793 0.3102043 0.30328838
## futebol_olimpico 0.4055775 0.49725018 0.3570130 0.4394000 0.37812471
## blog_cartola 0.1109195 0.19569116 0.0944325 0.0895449 0.09530284
## atletismo 0.6822016 0.52386932 0.6742534 0.3232127 0.40680161
## ginastica 0.4620644 0.30583551 0.4290135 0.4307485 0.32060148
## judo 0.3250207 0.20991462 0.2368430 0.5752857 0.36603063
## natacao 0.5749396 0.42564109 0.5101454 0.3214679 0.40659703
## basquete 1.0000000 0.55244365 0.6611498 0.3553491 0.36851921
## handebol 0.5524437 1.00000000 0.5162471 0.2573533 0.34051055
## volei 0.6611498 0.51624712 1.0000000 0.2514513 0.31382852
## tenis 0.3553491 0.25735334 0.2514513 1.0000000 0.34754875
## canoagem 0.3685192 0.34051055 0.3138285 0.3475487 1.00000000
## home 0.3189920 0.35551978 0.3079084 0.4081136 0.29173084
## saltos_ornamentais 0.5767395 0.68565596 0.5809540 0.1964784 0.30772787
## home_olimpiadas 0.6301982 0.64363200 0.6042541 0.4401590 0.40166517
## home saltos_ornamentais home_olimpiadas
## idade 0.1641235 0.08374999 0.1516083
## dias 0.6692593 0.41018477 0.6370551
## pviews 0.7818947 0.40579500 0.6647240
## visitas 0.7031741 0.40396841 0.6551574
## tempo_total 0.7510740 0.40144243 0.6628204
## futebol 0.7230650 0.29591792 0.5436195
## futebol_intenacional 0.4587482 0.26289220 0.4108400
## futebol_olimpico 0.5921329 0.39978940 0.5977142
## blog_cartola 0.3105620 0.14427119 0.2210504
## atletismo 0.3127823 0.62530621 0.6595690
## ginastica 0.3446832 0.35011750 0.4398998
## judo 0.4038979 0.16381880 0.3685489
## natacao 0.3263066 0.45637637 0.4906580
## basquete 0.3189920 0.57673950 0.6301982
## handebol 0.3555198 0.68565596 0.6436320
## volei 0.3079084 0.58095404 0.6042541
## tenis 0.4081136 0.19647844 0.4401590
## canoagem 0.2917308 0.30772787 0.4016652
## home 1.0000000 0.25663633 0.5376976
## saltos_ornamentais 0.2566363 1.00000000 0.6442230
## home_olimpiadas 0.5376976 0.64422296 1.0000000## Compare row 5 and column 3 with corr 0.94
## Means: 0.568 vs 0.414 so flagging column 5
## Compare row 3 and column 4 with corr 0.948
## Means: 0.545 vs 0.4 so flagging column 3
## Compare row 4 and column 2 with corr 0.975
## Means: 0.508 vs 0.385 so flagging column 4
## All correlations <= 0.9## [1] "tempo_total" "pviews" "visitas"### As variáveis "tempo_total" "pviews" "visitas" "dias" possuem alto correlação entre si (>0.75) e podem impactar o modelo.
## remover visitas e tempo_total
amostra_treino = amostra_treino %>% select(-visitas,-tempo_total)
### Coeficiente de associação:
amostra_treino_cat <- amostra_treino %>% select(sexo,device,regiao)
matriz_treino<-matrix(NA, nrow=ncol(amostra_treino_cat),ncol=ncol(amostra_treino_cat))
colnames(matriz_treino)<-colnames(amostra_treino_cat)
rownames(matriz_treino)<-colnames(amostra_treino_cat)
for(i in 1:ncol(amostra_treino_cat)){
for(j in 1:ncol(amostra_treino_cat)){
matriz_treino[i,j]<-round(CramerV(table(amostra_treino_cat[,i],amostra_treino_cat[,j]))
,digits=2)
}
}
as.data.frame(matriz_treino)## sexo device regiao
## sexo 1.00 0.02 0.03
## device 0.02 1.00 0.09
## regiao 0.03 0.09 1.00## All correlations <= 0.75## character(0)### Não há variáveis com correlação alta. Logo não iremos retirar nenhuma variável.
### Combinação Linear
base<-as.matrix(amostra_treino_qt)
(dl<-findLinearCombos(base))## $linearCombos
## list()
##
## $remove
## NULL### Variáveis Dummy
dummies <- dummyVars(Assinante_PRO~sexo+device+regiao,data=amostra_treino,fullRank=T)
var_dummies<-predict(dummies,newdata=amostra_treino)
amostra_treino<-cbind(amostra_treino,var_dummies)
amostra_treino<-amostra_treino %>% select(-sexo,-device,-regiao)
amostra_treino = amostra_treino %>% na.omit()No final, foram retiradas algumas informações que apresentaram correlação maior que 90% e que iriam atrapalhar na estimação dos modelos. Dentre as variáveis retiradas estão: visitas e tempo_total. Não haviam nenhuma variável com variância próxima de zero e nenhuma combinação linear. Com isso, entramos na etapa de testar os modelos.
Modelagem
Modelo Gradient Boosting
set.seed(217054078)
controle <- trainControl(method="repeatedcv", number=10,repeats=3)
grid <- expand.grid(interaction.depth=1,
n.trees = 100,
shrinkage=0.1,
n.minobsinnode=10)
set.seed(217054078)
#modelo_gbm<-caret::train(Assinante_PRO~., data=amostra_treino, method="gbm",
# distribution="bernoulli",
# trControl=controle,
# tuneGrid=grid,
# verbose=FALSE)
#save(modelo_gbm, file="Modelogbm.RData")
#ESSA PARTE DO CÓDIGO ESTÁ COMENTADA POIS NA LINHA ABAIXO, JÁ PODEMOS BAIXAR O MODELO JÁ PRONTO.
load("Modelogbm.RData")Modelo GLM (Regressão Logística)
### Modelo GLM
set.seed(217054078)
controle <- trainControl(method="repeatedcv", number=10,repeats=3)
#modelo_glm <- caret::train(Assinante_PRO~., data=amostra_treino, method="glm",
# trControl=controle)
#save(modelo_glm, file="Modeloglm.RData")
#ESSA PARTE DO CÓDIGO ESTÁ COMENTADA POIS NA LINHA ABAIXO, JÁ PODEMOS BAIXAR O MODELO JÁ PRONTO.
load("Modeloglm.RData")Modelo GLMBOOST (Regressão Logística Boosted)
set.seed(217054078)
#controle <- trainControl(method="repeatedcv", number=10,repeats=3)
#modelo_glmb <- caret::train(Assinante_PRO~., data=amostra_treino, method="glmboost",
# trControl=controle)
#save(modelo_glmb, file="ModeloglmB.RData")
#ESSA PARTE DO CÓDIGO ESTÁ COMENTADA POIS NA LINHA ABAIXO, JÁ PODEMOS BAIXAR O MODELO JÁ PRONTO.
load("ModeloglmB.RData")Modelo NAYVE BAYES
Aplicação da Amostra Teste
Aplicando regra de imputação
amostra_teste = mlr::reimpute(amostra_teste, preproc_NA)
## Tranformando variáveis categóricas em Dummy
dummies <- dummyVars(Assinante_PRO~sexo+device+regiao,data=amostra_teste,fullRank=T)
var_dummies<-predict(dummies,newdata=amostra_teste)
amostra_teste<-cbind(amostra_teste,var_dummies)
amostra_teste<-amostra_teste %>% select(-sexo,-device,-regiao)
### Retirando variáveis:
amostra_teste = amostra_teste %>% select(-visitas,-tempo_total)Modelo 1: GLM - Resultados na Amostra Teste
predicao = predict(modelo_glm ,amostra_teste)
caret::confusionMatrix(predicao,amostra_teste$Assinante_PRO)## Confusion Matrix and Statistics
##
## Reference
## Prediction Não Sim
## Não 4485 84
## Sim 3353 185
##
## Accuracy : 0.576
## 95% CI : (0.5652, 0.5868)
## No Information Rate : 0.9668
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.0379
##
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.57221
## Specificity : 0.68773
## Pos Pred Value : 0.98162
## Neg Pred Value : 0.05229
## Prevalence : 0.96682
## Detection Rate : 0.55323
## Detection Prevalence : 0.56359
## Balanced Accuracy : 0.62997
##
## 'Positive' Class : Não
## Modelo 2: GRADIENT BOOSTING - Resultados na Amostra Teste
predicao = predict(modelo_gbm ,amostra_teste)
caret::confusionMatrix(predicao,amostra_teste$Assinante_PRO)## Confusion Matrix and Statistics
##
## Reference
## Prediction Não Sim
## Não 6168 189
## Sim 1670 80
##
## Accuracy : 0.7707
## 95% CI : (0.7614, 0.7798)
## No Information Rate : 0.9668
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.0231
##
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.78694
## Specificity : 0.29740
## Pos Pred Value : 0.97027
## Neg Pred Value : 0.04571
## Prevalence : 0.96682
## Detection Rate : 0.76082
## Detection Prevalence : 0.78414
## Balanced Accuracy : 0.54217
##
## 'Positive' Class : Não
## Modelo 3: GLM BOOSTED - Resultados na Amostra Teste
predicao = predict(modelo_glmb ,amostra_teste)
caret::confusionMatrix(predicao,amostra_teste$Assinante_PRO)## Confusion Matrix and Statistics
##
## Reference
## Prediction Não Sim
## Não 4519 82
## Sim 3319 187
##
## Accuracy : 0.5805
## 95% CI : (0.5697, 0.5913)
## No Information Rate : 0.9668
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.0399
##
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.57655
## Specificity : 0.69517
## Pos Pred Value : 0.98218
## Neg Pred Value : 0.05334
## Prevalence : 0.96682
## Detection Rate : 0.55742
## Detection Prevalence : 0.56753
## Balanced Accuracy : 0.63586
##
## 'Positive' Class : Não
## Modelo 4: NAYVE BAYES - Resultados na Amostra Teste
predicao = predict(modelo_nb ,amostra_teste)
caret::confusionMatrix(predicao,amostra_teste$Assinante_PRO)## Confusion Matrix and Statistics
##
## Reference
## Prediction Não Sim
## Não 1760 81
## Sim 6078 188
##
## Accuracy : 0.2403
## 95% CI : (0.231, 0.2497)
## No Information Rate : 0.9668
## P-Value [Acc > NIR] : 1
##
## Kappa : -0.0065
##
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.2245
## Specificity : 0.6989
## Pos Pred Value : 0.9560
## Neg Pred Value : 0.0300
## Prevalence : 0.9668
## Detection Rate : 0.2171
## Detection Prevalence : 0.2271
## Balanced Accuracy : 0.4617
##
## 'Positive' Class : Não
## O modelo Gradient Boosting apresentou melhores resultados de Acurácia, porém, quando olhamos outras métricas, como especificidade, os demais modelos apresentaram os melhores resultados.
Além disso, é possível extrair a lista dos usuários que o modelo diz que é Assinante PRO, mas não é realmente. Esses usuários foram classificados como Assinantes Cartola Pro por ter o perfil parecido com os cartoleiros PRO e tem alta probabilidade de se tornar PRO.
Para isso, iremos avaliar o perfil dos assinantes que o modelo de regressão logística boosted previu ser assinante cartoleiro PRO.
predicao = predict(modelo_glmb ,amostra_teste)
amostra_teste$Previsao = predicao
amostra_teste %>% select(idade,dias,futebol,blog_cartola,Previsao) %>% group_by(Previsao) %>% summarise(idade = mean(idade),
dias = mean(dias),
futebol = mean(futebol),
blog_cartola = mean(blog_cartola))## # A tibble: 2 × 5
## Previsao idade dias futebol blog_cartola
## <fct> <dbl> <dbl> <dbl> <dbl>
## 1 Não 26.0 5.17 1740. 504.
## 2 Sim 28.8 16.0 8284. 2372.Nota-se que, a idade média dos usuários classificados como PRO é maior, o uso diário do cartola e o consumo de editorias de futebol e do blog cartola também são superiores.
amostra_teste %>% filter(Previsao == "Sim") %>% select(sexo.M) %>% group_by(sexo.M) %>% summarise(N= n())## # A tibble: 2 × 2
## sexo.M N
## <dbl> <int>
## 1 0 56
## 2 1 3450amostra_teste %>% filter(Previsao == "Sim") %>% select(regiao.Nordeste) %>% group_by(regiao.Nordeste) %>% summarise(N= n())## # A tibble: 2 × 2
## regiao.Nordeste N
## <dbl> <int>
## 1 0 2982
## 2 1 524amostra_teste %>% filter(Previsao == "Sim") %>% select(regiao.Sudeste) %>% group_by(regiao.Sudeste) %>% summarise(N= n())## # A tibble: 2 × 2
## regiao.Sudeste N
## <dbl> <int>
## 1 0 1048
## 2 1 2458amostra_teste %>% filter(Previsao == "Sim") %>% select(regiao.Sul) %>% group_by(regiao.Sul) %>% summarise(N= n())## # A tibble: 2 × 2
## regiao.Sul N
## <dbl> <int>
## 1 0 3161
## 2 1 345amostra_teste %>% filter(Previsao == "Sim") %>% select(regiao.Norte) %>% group_by(regiao.Norte) %>% summarise(N= n())## # A tibble: 2 × 2
## regiao.Norte N
## <dbl> <int>
## 1 0 3468
## 2 1 38O perfil de gênero e de região também em linha com o que foi analisado anteriormente.
Clusterização - Uma análise de perfil de consumo dos assinantes PRO
Para realizar a análise de perfil de consumo dos assinantes Cartola PRO, foi utilizado a técnicas de clusterização, com o objetivo de traçar diferentes perfis de assinantes baseado nos consumos de editorias.
Para isso, foram selecionadas todas as variáveis de consumo e aplicou-se uma normalização para melhorar o processo de diferenciação entre os grupos.
BASE_CLUSTERS_PRO = base_modelo %>% filter(Assinante_PRO == "Sim") %>% select(futebol,futebol_intenacional,futebol_olimpico,blog_cartola,atletismo,ginastica,judo,natacao,basquete,handebol,volei,tenis,canoagem,home,home_olimpiadas,saltos_ornamentais) %>% scale()Testou-se o método de agrupamento em até 6 grupos, mas baseado nos resultados e na variância explicada, o melhor agrupamento foi utilizando 3 grupos.
set.seed(123)
km.res1_S <- kmeans(BASE_CLUSTERS_PRO, 1,algorithm = "Hartigan-Wong", nstart = 25)
km.res2_S <- kmeans(BASE_CLUSTERS_PRO, 2,algorithm = "Hartigan-Wong", nstart = 25)
km.res3_S <- kmeans(BASE_CLUSTERS_PRO, 3,algorithm = "Hartigan-Wong", nstart = 25)
km.res4_S <- kmeans(BASE_CLUSTERS_PRO, 4,algorithm = "Hartigan-Wong", nstart = 25)
km.res5_S <- kmeans(BASE_CLUSTERS_PRO, 5,algorithm = "Hartigan-Wong", nstart = 25)
km.res6_S <- kmeans(BASE_CLUSTERS_PRO, 6,algorithm = "Hartigan-Wong", nstart = 25)
tabela_simples = data.frame( WITHIN_VAR = c(km.res1_S$tot.withinss,
km.res2_S$tot.withinss,
km.res3_S$tot.withinss,
km.res4_S$tot.withinss,
km.res5_S$tot.withinss,
km.res6_S$tot.withinss),
K = 1:6)
plot(x = tabela_simples$K, y=tabela_simples$WITHIN_VAR, ylab = "Variancia Intra-Clusters", xlab="Numero K de Clusters", type="l", main = "Definicao Otima da Quantidade de Clusters - Visao Simples")
abline(v=3, col="blue")
abline(v=4, col="red")
fviz_cluster(km.res3_S , data = BASE_CLUSTERS_PRO , stand=F, geom = "point",main = "Grupos de Assinantes PRO",star.plot = TRUE) + theme_classic()
Ao final, temos as medidas dos centróides dos grupos em relação a cada variável, e a partir delas, podemos entender como cada grupo é formado e caracterizado.
## futebol futebol_intenacional futebol_olimpico blog_cartola atletismo
## 1 0.6425304 1.3413670 2.6919245 0.2640328 2.2427753
## 2 1.6616776 0.7625200 0.9141854 1.1083026 0.2256048
## 3 -0.2635074 -0.1634705 -0.2400498 -0.1690643 -0.1234190
## ginastica judo natacao basquete handebol volei tenis
## 1 2.2304077 2.6136052 0.83778993 2.3810762 3.0072527 1.1088699 2.5997242
## 2 0.1059506 0.1319207 0.37575387 0.2697293 0.2175924 1.1342791 0.3828550
## 3 -0.1058227 -0.1251133 -0.08774311 -0.1353457 -0.1533575 -0.2071258 -0.1603966
## canoagem home home_olimpiadas saltos_ornamentais
## 1 3.0524025 0.7339048 2.8709059 0.2619701
## 2 0.1625371 1.4830848 0.7741934 0.7768017
## 3 -0.1473283 -0.2417093 -0.2273282 -0.1216232Notou-se a formação de 3 grupos:
- 1.OS CONSUMIDORES HEAVY DE FUTEBOL NACIONAL E DE CONTEÚDOS SOBRE CARTOLA;
- 2.OS CONSUMIDORES HEAVY DE FUTEBOL INTERNACIONAL E DAS DEMAIS MODALIDADES;
- 3.OS CONSUMIDORES LIGHT DE CONTEÚDO ESPORTIVO.
Com as seguintes proporções:
##
## 1 2 3
## 0.03435469 0.12070566 0.84493965Com isso, traçamos um perfil, demográfico ou de consumo, dos cartoleiros PRO e através do modelo de propensão