Predição - Progresso dos usuários no jogo
Rodolfo Viana
19-06-2016
Modelagem do Problema
Utilizando o dataset referente ao comportamento de 10.000 usuários em um jogo, queremos saber qual será o progresso dos usuários no jogo daqui a 2 dias?
É apresentado um dataset de um jogo com features de 10.000 usuários que possuem activation date no período de 25/05 até 28/05, exclusive.
O dataset está dividido em training (70%) e test set (30%), ambos compostos por features dos usuários nesse mesmo período: o training set terá ainda uma coluna de gabarito dizendo qual é o progresso do usuário 2 dias depois do período capturado (no dia 30/05). O test set será utilizado para testar a precisão do modelo.
# Carregando as bibliotecas necessárias
library(dplyr)
library(ggplot2)
library(caret)
library(corrplot)
library(h2o)Exploração dos dados
# Carregando os dados
dados <- read.csv("~/Desktop/tfg/Dados/training_progress_predictor-3.csv")
# Dim do dataset
dim(dados)## [1] 7000 15Temos 7000 observações no treino e 15 features.
# Conta quantos casos não completo existe
sum(!complete.cases(dados))## [1] 0Não existe caso com observações incompletas, aparentemente.
# Nome das colunas
colnames(dados)## [1] "user" "revenue" "units" "ls.date"
## [5] "tsls" "rating" "ttp" "total.sessions"
## [9] "completed" "completed.post" "win.rate" "tries"
## [13] "device" "tbs" "tsad"As features são referentes ao período desde o activation date até o dia 28/05 exclusive e são:
- user: Id do usuário
- revenue: total gasto pelo usuário
- units:
- ls.date: data da última sessão
- tsls: tempo desde a última sessão (s)
- rating: opção no popup de rating (Yes (1), No (0), None (-1))
- ttp: tempo total jogado (s)
- total.sessions: número total de sessões
- completed: porcentagem do jogo completa
- completed.post: porcentagem do jogo completa após 2 dias
- win.rate: overall Win Rate (%)
- tries: número de tentativas totais
- device: device que o usuário está jogando (iPhone, iPad, iPod)
- tbs: médio entre sessões desde o activation date (s)
- tsad: tempo desde a última sessão (s)
As 6 primeiras observações do dataset
# Head do dataset
head(dados)## user revenue units ls.date tsls rating ttp total.sessions
## 1 3567 NULL NULL 2015-05-26 90252 -1 548 3
## 2 6562 NULL NULL 2015-05-26 162217 -1 656 3
## 3 6233 NULL NULL NULL NULL 0 0 1
## 4 7004 NULL NULL 2015-05-26 170643 0 1340 4
## 5 1450 NULL NULL 2015-05-27 3524 0 4170 2
## 6 5592 NULL NULL 2015-05-27 35612 0 2563 4
## completed completed.post win.rate tries device tbs
## 1 0.155555555556 0.155555555556 0.25 4.0 ipod 46193.0
## 2 0.222222222222 0.266666666667 0.333333333333 6.0 iphone 44790.0
## 3 0.222222222222 0.222222222222 1.0 3.0 ipad NULL
## 4 0.177777777778 0.177777777778 0.272727272727 11.0 iphone 861.333333333
## 5 0.333333333333 0.666666666667 1.0 7.0 ipad 34807.0
## 6 0.444444444444 0.444444444444 0.45 20.0 iphone 57243.0
## tsad
## 1 182922
## 2 162896
## 3 81136
## 4 173408
## 5 39989
## 6 207761As 6 últimas observações do dataset
# Tail do dataset
tail(dados)## user revenue units ls.date tsls rating ttp total.sessions
## 6995 1486 NULL NULL 2015-05-26 90260 -1 5148 6
## 6996 4724 NULL NULL 2015-05-27 1556 0 10379 4
## 6997 5425 NULL NULL NULL NULL 0 0 1
## 6998 5431 NULL NULL 2015-05-25 189075 0 308 4
## 6999 2095 NULL NULL 2015-05-27 57826 0 7291 6
## 7000 3344 NULL NULL NULL NULL 0 0 1
## completed completed.post win.rate tries device
## 6995 0.333333333333 0.555555555556 0.625 8.0 ipad
## 6996 0.777777777778 0.844444444444 0.65 40.0 ipad
## 6997 0.222222222222 0.222222222222 0.5 4.0 iphone
## 6998 0.222222222222 0.222222222222 0.6 5.0 iphone
## 6999 0.333333333333 0.444444444444 0.304347826087 23.0 iphone
## 7000 0.177777777778 0.177777777778 0.666666666667 3.0 iphone
## tbs tsad
## 6995 4324.4 112542
## 6996 7593.33333333 24268
## 6997 NULL 9293
## 6998 638.333333333 190965
## 6999 22073.0 169368
## 7000 NULL 242493O nosso dataset possui a seguinte estrutura
# Structure do dataset
str(dados)## 'data.frame': 7000 obs. of 15 variables:
## $ user : int 3567 6562 6233 7004 1450 5592 711 293 7545 7884 ...
## $ revenue : Factor w/ 17 levels "10.0","100.0",..: 17 17 17 17 17 17 17 17 17 17 ...
## $ units : Factor w/ 5 levels "1","2","3","4",..: 5 5 5 5 5 5 5 5 5 5 ...
## $ ls.date : Factor w/ 4 levels "2015-05-25","2015-05-26",..: 2 2 4 2 3 3 2 3 4 4 ...
## $ tsls : Factor w/ 4691 levels "1000","100063",..: 4442 1058 4691 1227 2941 2963 672 2332 4691 4691 ...
## $ rating : int -1 -1 0 0 0 0 0 1 0 0 ...
## $ ttp : int 548 656 0 1340 4170 2563 775 1684 0 0 ...
## $ total.sessions: int 3 3 1 4 2 4 2 5 1 1 ...
## $ completed : Factor w/ 41 levels "0.133333333333",..: 2 5 5 3 10 15 5 5 5 5 ...
## $ completed.post: Factor w/ 44 levels "0.133333333333",..: 2 7 5 3 25 15 5 5 5 5 ...
## $ win.rate : Factor w/ 621 levels "0.025","0.037037037037",..: 107 179 620 124 620 328 569 585 569 384 ...
## $ tries : Factor w/ 146 levels "1.0","10.0","100.0",..: 81 103 70 12 114 55 81 92 81 103 ...
## $ device : Factor w/ 3 levels "ipad","iphone",..: 3 2 1 2 1 2 2 1 2 1 ...
## $ tbs : Factor w/ 4006 levels "0.0","10.0","100.0",..: 2715 2669 4006 3718 2248 3025 2490 3692 4006 4006 ...
## $ tsad : int 182922 162896 81136 173408 39989 207761 134553 36441 81007 153839 ...Completed Post
O comportamento da variável resposta é
dados$completed.post <- as.numeric(as.character(dados$completed.post))
sum(!complete.cases(dados$completed.post))## [1] 175Notamos que temos 175 casos em que o completed.post é desconhecido
ggplot(data=dados, aes(dados$completed.post*100)) +
geom_histogram(aes(fill=..count..)) +
labs(title="Histograma do Completed Post") +
labs(x="% do jogo completo após 2 dias", y="Count") +
scale_fill_gradient("Count", low = "green", high = "red") +
theme_classic()
Temos uma maior concentração da variável completed.post em torno de valores abaixo de 30%
min(dados$completed.post, na.rm = TRUE)## [1] 0.1333333max(dados$completed.post, na.rm = TRUE)## [1] 1.111111A variável completed post varia de 0.1333333 para 1.1111111. Temos valores acima de 1, o que chega a ser um pouco anormal pois acredito que essa variável deveria ser um valor entre 0-1. Eu deveria então investigar como que foi a aquisição dos dados para verificar se essa minha suspeita faz sentido.
Revenue
Total gasto pelo usuário
dados$revenue <- as.numeric(as.character(dados$revenue))
sum(!complete.cases(dados$revenue))## [1] 6970Temos 6970 casos em que o revenue é desconhecido. O que é um valor bastante alto. Talvez essa variável não seja útil para a criação do nosso modelo.
ggplot(data=dados, aes(dados$revenue)) +
geom_histogram() +
labs(title="Histograma do total gasto pelo usuário") +
labs(x="Total gasto pelo usuário", y="Count") +
theme_classic()
A grande maioria dos usuários não gastam no jogo.
Units
A proporção da variável units é:
prop.table(table(dados$units))##
## 1 2 3 4 NULL
## 0.0027142857 0.0005714286 0.0004285714 0.0005714286 0.9957142857A grande maioria das nossa observações tem o valor NULL na variável units. No gráfico abaixo é possível notar como é grande a diferença nos valores.
toPlot <- as.data.frame(prop.table(table(dados$units)))
ggplot(toPlot, aes(x = Var1, y = Freq)) +
geom_bar(stat="identity") +
labs(y='Frequency', x='Type of test result') +
theme_classic() +
theme(axis.ticks = element_blank())
TSLS
Tempo desde a última sessão
dados$tsls <- as.numeric(as.character(dados$tsls))
sum(!complete.cases(dados$tsls))## [1] 2233Temos 2233 casos em que o tsls é desconhecido.
boxplot(dados$tsls, data=dados$tsls, main="Car Milage Data",
xlab="Number of Cylinders", ylab="Miles Per Gallon")
summary(dados$tsls, na.rm = TRUE)## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
## 3 19190 54950 81190 131400 258800 2233A média de tempo desde a última sessão é de 8.119244810^{4}
TTP
Tempo total jogado
sum(!complete.cases(dados$ttp))## [1] 0Temos 0 casos em que o ttp é desconhecido. O que é uma noticia muito boa já que essa variável pode ser bem importante pare o modelo. Acredito inicialmente que quanto maior for o tempo total jogado maior será o progresso do usuário
summary(dados$ttp, na.rm = TRUE)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.0 0.0 531.5 2245.0 2503.0 62560.0O maior tempo total jogado é (em segundos) 62563 o que são mais ou menos 17.3786111 horas. O tempo médio total jogado é (em segundos) 2244.997
Corelação TTP x Completed Post
Para verificar se quanto maior o tempo total maior será o progresso do usuário iremos verificar a correlação entre as variáveis TTP x Completed Post
cor(dados$completed.post, dados$ttp, use = 'complete.obs') ## [1] 0.7219596A correlação é um valor que varia entre -1 e 1. Quanto mais próximo de 0 menor é a correlação entre as duas variávei. Para o dataset observado temos uma correlação de 0.7219596. Temos uma correlação positiva, o que significa que quando um valor crescer o outro também irá crescer na maioria dos casos.
Conclusões da inicial exploração dos dados:
- Existe uma necessidade de transformar as variáveis (muita vezes de factor para númeric);
- A variável completed.post não tem distribuição uniforme. A grande maioria dos valores ficam abaixo de 0.3
- Temos muitos valores NULL/NA
- O campo ls.date podem ser convertidos em novas features (ano, mês, dia)
- A variável completed.post tem valores acima de 1, o que pode significar um erro nos dados.
Preparação dos Dados
Deletando valores “anormais”
Por acreditar que um valor maior que 1 na variável completed.post seja um erro na aquisição dos dados, iremos deletar essas observações. Também iremos deletar observações com NA na variável completed post pela mesma razão.
dados <- filter(dados, completed.post <= 100)Derivando novas features
Iremos criar 5 novas colunas derivadas da variável ls.date (data, dia, mês, ano, dia da semana).
# Data
dados$data <- as.Date(as.character(dados$ls.date), format = "%Y-%m-%d")
# Ano
dados$ano <- as.numeric(format(dados$data, format = '%Y'))
# Mes
dados$mes <- as.numeric(format(dados$data, format = '%m'))
# Dia
dados$dia <- as.numeric(format(dados$data, format = '%j'))
# Dia da semana
dados$dia.semana <- format(dados$data, format = '%u')Removendo variáveis com near-zero variance
Nem sempre ter muitos dados significa ter muita informação relevante. Pensando nisso, iremos deletar as colunas que tem uma variância perto de zero, pois elas não vão agregar informação importante para a criação do modelo de predição.
colnames(dados[(nearZeroVar(dados, saveMetrics = FALSE))])## [1] "units" "ano" "mes"As colunas units, ano, mes tem uma variância próxima a zero e por essa razão iremos deletar.
dados <- dados[-(nearZeroVar(dados, saveMetrics = FALSE))]Correlação
Temos uma apresentação visual das correlações entre as variáveis numéricas. Antes iremos transformar de factor para númerico as variáveis tsls, win rate, tries, tbs, dia semana.
dados$tsls <- as.numeric(as.character(dados$tsls))
dados$win.rate <- as.numeric(as.character(dados$win.rate))
dados$tries <- as.numeric(as.character(dados$tries))
dados$tbs <- as.numeric(as.character(dados$tbs))
dados$dia.semana <- as.numeric(as.character(dados$dia.semana))nums <- sapply(dados, is.numeric)
correlations <- cor(dados[,nums], use = 'complete.obs')
corrplot(correlations, order = "hclust")
Neste plot você pode ver a correlação entre todas as variáveis. Duas variáveis podem ter uma correlação positiva, uma correlação negativa ou uma correlação neutra. Quando o ponto é vermelho, isso significa que temos uma correlação negativa. Quando o ponto é azul, temos uma correlação positiva. Branco significa que estas duas variáveis não tem nenhuma correlação.
Completed Post tem correlação forte com: completed, total sessions, ttp, tries, dia, dia semana, tsls
Muitas vezes não é interessante ter duas variáveis que dizem a mesma coisa. Como é o caso de dia e dia semana. Perceba que elas tem praticamente os mesmos valores de correlação com as demais variáveis. Por essa razão iremos ficar apenas com dia.
dados$dia.semana <- NULLOutliers
Utilizando o boxplot iremo observar se as variáveis tsls, ttp, total sessions, tries, tbs, tsad possuem outliers.
boxplot(dados$tsls, data=dados$tsls, main="TSLS",
ylab="Tempo desde a última sessão")
O tempo desde a última sessão não possui outlier
boxplot(dados$ttp, data=dados$ttp, main="TTP",
ylab="Tempo total jogado")
O tempo total jogado apresenta muitos outliers. Talvez seja interessante excluir os outliers em algum modelo no futuro. Pois muitas vezes outliers podem influenciar negativamente um modelo
boxplot(dados$total.sessions, data=dados$total.sessions, main="Total Sessions",
ylab="Número total de sessões")
O número total de sessões apresenta muitos outliers
boxplot(dados$tries, data=dados$tries, main="Tries",
ylab="Número de tentativas totais")
O número de tentativas totais apresenta muitos outliers
boxplot(dados$tbs, data=dados$tbs, main="TBS",
ylab="Média entre sessões desde o activation date")
A média entre sessões desde o activation date apresenta um número razoável de outliers
boxplot(dados$tsad, data=dados$tsad, main="TSAD",
ylab="Tempo desde a última sessão")
O tempo desde a última sessão não apresenta outlier.
Foi decidido que não iriamos deletar os outliers inicialmente. Talvez seja interessante excluir no futuro como um das estratégias para melhorar o modelo.
Sumarização
Uma sumarização geral dos dados pode ser observada a seguir:
summary(dados)## user revenue ls.date tsls
## Min. : 3 Min. : 4.00 2015-05-25: 795 Min. : 3
## 1st Qu.: 2504 1st Qu.: 5.00 2015-05-26:1047 1st Qu.: 19048
## Median : 5009 Median : 10.00 2015-05-27:2894 Median : 54072
## Mean : 5003 Mean : 24.40 NULL :2089 Mean : 80748
## 3rd Qu.: 7504 3rd Qu.: 22.25 3rd Qu.:130629
## Max. :10000 Max. :147.00 Max. :258798
## NA's :6795 NA's :2089
## rating ttp total.sessions completed
## Min. :-1.0000 Min. : 0 Min. : 1.000 0.222222222222:1233
## 1st Qu.:-1.0000 1st Qu.: 0 1st Qu.: 1.000 0.133333333333:1210
## Median : 0.0000 Median : 577 Median : 2.000 0.155555555556: 740
## Mean :-0.2135 Mean : 2302 Mean : 4.014 0.177777777778: 573
## 3rd Qu.: 0.0000 3rd Qu.: 2573 3rd Qu.: 5.000 0.444444444444: 508
## Max. : 1.0000 Max. :62563 Max. :67.000 0.333333333333: 493
## (Other) :2068
## completed.post win.rate tries device
## Min. :0.1333 Min. :0.0250 Min. : 1.00 ipad :2133
## 1st Qu.:0.1556 1st Qu.:0.5000 1st Qu.: 3.00 iphone:4202
## Median :0.2222 Median :0.6667 Median : 7.00 ipod : 490
## Mean :0.3224 Mean :0.6756 Mean : 14.95
## 3rd Qu.:0.4222 3rd Qu.:1.0000 3rd Qu.: 18.00
## Max. :1.1111 Max. :1.0000 Max. :236.00
## NA's :565 NA's :565
## tbs tsad data dia
## Min. : 0 Min. : 9 Min. :2015-05-25 Min. :145.0
## 1st Qu.: 3088 1st Qu.: 74866 1st Qu.:2015-05-26 1st Qu.:146.0
## Median : 12348 Median :140621 Median :2015-05-27 Median :147.0
## Mean : 22384 Mean :135826 Mean :2015-05-26 Mean :146.4
## 3rd Qu.: 27734 3rd Qu.:199763 3rd Qu.:2015-05-27 3rd Qu.:147.0
## Max. :1166861 Max. :259180 Max. :2015-05-27 Max. :147.0
## NA's :2658 NA's :2089 NA's :2089Notamos que as variáveis ls.date, tsls e tbs possuem grande quantidade de valores NA/NULL. Se necessário podemos pensar no futuro em Imputation para os valores que estão faltando.
Um modelo básico
Para a criação do modelo utilizei a biblioteca h2o, por se tratar de um open-source software para big-data analysis. O h2o é bastante rápido e flexível, podendo assim ser possível carregar uma grande quantidade de dados. Faz parte de uma comunidade que vem crescendo cada dia mais.
Inicialmente iremos criar 3 modelos básicos onde cada modelo será de um algoritmo diferente. Iremos utilizar:
- GLM (Generalized linear model)
- Random Florest
- GBM (Gradient Boosting Algorithm)
O nosso objetivo nessa etapa é encontrar o melhor modelo para o nosso problema sem utilizar nenhum tipo de pre processamento, transformação, criação de features. Depois de encontrado o melhor modelo iremos aplicar todo o pre processamento já feito, transformação de variáveis, etc. Com o objetivo final de deixar o modelo ainda melhor.
Dividindo os dados em treino e validação
Inicialmente vamos dividir o dataset entre o dataset de treino (80%) e validação(20%). Essa divisão é importante por evita o overfitting, que ocorre quando um modelo estatístico super se adapta ao conjunto treinado, dessa forma quando o modelo recebe um valor pelo o qual ele não foi treinado, ele vai gerar uma predição muito ruim. Além disso, é importante essa divisão entre treino e validação para verificar em qual ponto o modelo começa a sofrer overfitting.
dados.originais <- read.csv("Dados/training_progress_predictor-3.csv")
# Dividindo os dados
set.seed(123)
train.Index <- createDataPartition(dados.originais$completed.post, p = .8, list = F, times = 1)
dados.treino <- dados.originais[ train.Index,]
dados.valida <- dados.originais[-train.Index,]
# Add nome das colunas
names(dados.treino) = names(dados.originais)
names(dados.valida) = names(dados.originais)
write.csv2(dados.treino, file = 'Dados/treino.csv', row.names = FALSE)
write.csv2(dados.valida, file = 'Dados/validacao.csv', row.names = FALSE)Criando vários modelos
# Carregando a biblioteca h2o
conn <- h2o.init(nthreads = -1)
# Importando arquivo no h2o
path.input <- "/home/rodolfo/Desktop/tfg/Dados/treino.csv"
dados.train <- h2o.importFile(path = path.input, destination_frame = "train.hex")
path.validacao <- "/home/rodolfo/Desktop/tfg/Dados/validacao.csv"
dados.validacao <- h2o.importFile(path = path.validacao, destination_frame = "validacao.hex")Vamos inicialmente trabalhar com os modelos GBM, random florest e GLM. O ideal seria inicialmente rodar todos os modelos com um grande número de árvores, grande profundidade e uma taxa de aprendizado pequena por interação, porém isso leva um tempo grande na minha máquina atual (com apenas 4GB)
# Coluna que se deseja prever
myY <- "completed.post"
# Coluna que deve ser ignorada pelo modelo
ignored_columns <- "completed.post"
myX <- setdiff(setdiff(names(dados.train), myY), ignored_columns)
# GBM
gbm <- h2o.gbm(x = myX, build_tree_one_node = T,
y = myY,
training_frame = dados.train,
validation_frame = dados.validacao,
ntrees = 50,
max_depth = 6,
learn_rate = 0.1)
# DRF
drf <- h2o.randomForest(x = myX,
y = myY,
training_frame = dados.train,
validation_frame = dados.validacao,
ntrees = 50,
max_depth = 30)
# GLM
glm <- h2o.glm(x = myX,
y = myY,
training_frame = dados.train,
validation_frame = dados.validacao,
lambda = 1e-5)# Score de cada modelo
trainr2.gbm <- h2o.r2(gbm)
testr2.gbm <- h2o.r2(gbm, valid = TRUE)
trainr2.drf <- h2o.r2(drf)
testr2.drf <- h2o.r2(drf, valid = TRUE)
trainr2.glm <- h2o.r2(glm)
testr2.glm <- h2o.r2(glm, valid = TRUE)
toPlot <- data.frame(Rsquared = c(trainr2.gbm, testr2.gbm, trainr2.drf, testr2.drf, trainr2.glm, testr2.glm),
tipo = c("treino", "validacao", "treino", "validacao", "treino", "validacao"),
modelo = c("GBM","GBM","RF", "RF","GLM", "GLM"))Para verificar qual dos 3 modelos é o melhor, utilizamos a métrica Rsquared, onde o valor do Rsquared (entre 0 e 1) é o percentual de variância explicada pelo o modelo. Na regressão, o Rsquared é uma medida estatística de quão bem a linha de regressão aproxima os pontos de dados reais. Um Rsquared igual a 1 indica que a linha de regressão encaixa perfeitamente os dados. Quanto maior foi o Rsquared melhor é o modelo.
ggplot(data=toPlot, aes(x = modelo, y = Rsquared, fill = tipo)) +
geom_bar(stat="identity", position=position_dodge()) +
theme_classic() +
labs(title = "Comparando os modelos") +
theme(axis.ticks = element_blank())
É possível notar que o GBM teve um melhor resultado do que os outros modelos, obtendo assim um Rsquared maior. Por esse motivo optamos por escolher o modelo GBM para realizar a predição. Porém antes de realizar a predição vamos tentar melhor ainda mais esse modelo utilizando várias estratégias.
Investigando o GBM
Como o GBM foi o escolhido, é interessante observar como se deu o treinamento ao longo das criações das árvores. Para evitar o overfitting dividimos os dados de treino em treino e validação. Dessa forma podemos observar o exato momento em que o modelo pode passa a sofrer o overfitting.
A linha azul significa a evolução do treino e a linha laranja significa a evolução da validação. É possível notar que depois da árvore 30, o modelo meio que se estabiliza.
GBM com menos árvores.
Como observado anteriormente, depois da árvore 30 o modelo se estabiliza. Por esse motivo criamos um novo modelo, dessa vez parando o treinamento na árvore 30, já que treinar além da árvore 30 traz pouco beneficio para o modelo.
# GBM
gbm.30 <- h2o.gbm(x = myX, build_tree_one_node = T,
y = myY,
training_frame = dados.train,
validation_frame = dados.validacao,
ntrees = 30,
max_depth = 6,
learn_rate = 0.1)
# Score de cada modelo
trainr2gbm.30 <- h2o.r2(gbm.30)
testr2gbm.30 <- h2o.r2(gbm.30, valid = TRUE)ggplot(data=toPlot, aes(x = modelo, y = Rsquared, fill = tipo)) +
geom_bar(stat="identity", position=position_dodge()) +
theme_classic() +
labs(title = "Comparando os modelos GBM") +
theme(axis.ticks = element_blank())
É possível notar que mesmo utilizando menos árvores o valor do Rsquared foi praticamente o mesmo. O que significa que em menos tempo, com menos processamento, conseguimos um resultado similar.
É interessante notar também a importância das variáveis para a criação dos modelos.
Notamos que a variável completed, tsad, ttp, tsls foram as variáveis com maior importância para a criação do modelo. Esse comportamento já foi previsto antes mesmo da criação do modelo quando a gente verificou a correlação entre a variável respostas e demais variáveis.
GBM com nova features
Ao criar novas variáveis podemos agregar valor e melhorar o modelo.
Foi observado no pré processamento que é interessante adicionar uma nova feature derivada da variável ls.date. Vamos adicionar essa nova feature e criar um novo modelo.
# Data
dados.treino$data <- as.Date(as.character(dados.treino$ls.date), format = "%Y-%m-%d")
dados.valida$data <- as.Date(as.character(dados.valida$ls.date), format = "%Y-%m-%d")
# Dia
dados.treino$dia <- as.numeric(format(dados.treino$data, format = '%j'))
dados.valida$dia <- as.numeric(format(dados.valida$data, format = '%j'))
dados.treino$data <- NULL
dados.treino$ls.date <- NULL
dados.valida$ls.date <- NULL
dados.valida$data <- NULL
write.csv2(dados.treino, file = 'Dados/treino_2.csv', row.names = FALSE)
write.csv2(dados.valida, file = 'Dados/validacao_2.csv', row.names = FALSE)
# Importando arquivo no h2o
path.input <- "/home/rodolfo/Desktop/tfg/Dados/treino_2.csv"
dados.train <- h2o.importFile(path = path.input, destination_frame = "train.hex")
path.validacao <- "/home/rodolfo/Desktop/tfg/Dados/validacao_2.csv"
dados.validacao <- h2o.importFile(path = path.validacao, destination_frame = "validacao.hex")
# Coluna que se deseja prever
myY <- "completed.post"
# Coluna que deve ser ignorada pelo modelo
ignored_columns <- "completed.post"
myX <- setdiff(setdiff(names(dados.train), myY), ignored_columns)
# GBM
gbm_3 <- h2o.gbm(x = myX, build_tree_one_node = T,
y = myY,
training_frame = dados.train,
validation_frame = dados.validacao,
ntrees = 30,
max_depth = 6,
learn_rate = 0.1)
# Score de cada modelo
trainr2.gbm3 <- h2o.r2(gbm_3)
testr2.gbm3 <- h2o.r2(gbm_3, valid = TRUE)ggplot(data=toPlot, aes(x = modelo, y = Rsquared, fill = tipo)) +
geom_bar(stat="identity", position=position_dodge()) +
theme_classic() +
labs(title = "Comparando os modelos GBM") +
theme(axis.ticks = element_blank())
Essa nova feature não proporcionou nenhuma melhora no nosso modelo.
GBM sem variáveis near-zero variance
Foi visto anteriormente que algumas colunas tem uma variância perto de zero, elas não vão agregar informação importante para a criação do modelo de predição. Por esse motivo vamos excluir e treinar o modelo novamente para verificar se temos algum ganho.
dados.treino <- dados.treino[-(nearZeroVar(dados.treino, saveMetrics = FALSE))]
dados.valida <- dados.valida[-(nearZeroVar(dados.valida, saveMetrics = FALSE))]Além disso, também iremos excluir a coluna user por ser apenas o ID de um user e não agregar valor.
dados.treino$user <- NULL
dados.valida$user <- NULL
write.csv2(dados.treino, file = 'Dados/treino_3.csv', row.names = FALSE)
write.csv2(dados.valida, file = 'Dados/validacao_3.csv', row.names = FALSE)
# Importando arquivo no h2o
path.input <- "/home/rodolfo/Desktop/tfg/Dados/treino_3.csv"
dados.train <- h2o.importFile(path = path.input, destination_frame = "train.hex")
path.validacao <- "/home/rodolfo/Desktop/tfg/Dados/validacao_3.csv"
dados.validacao <- h2o.importFile(path = path.validacao, destination_frame = "validacao.hex")
# Coluna que se deseja prever
myY <- "completed.post"
# Coluna que deve ser ignorada pelo modelo
ignored_columns <- "completed.post"
myX <- setdiff(setdiff(names(dados.train), myY), ignored_columns)
# GBM
gbm_4 <- h2o.gbm(x = myX, build_tree_one_node = T,
y = myY,
training_frame = dados.train,
validation_frame = dados.validacao,
ntrees = 30,
max_depth = 6,
learn_rate = 0.1)
# Score de cada modelo
trainr2.gbm4 <- h2o.r2(gbm_4)
testr2.gbm4 <- h2o.r2(gbm_4, valid = TRUE)ggplot(data=toPlot, aes(x = modelo, y = Rsquared, fill = tipo)) +
geom_bar(stat="identity", position=position_dodge()) +
theme_classic() +
labs(title = "Comparando os modelos GBM") +
theme(axis.ticks = element_blank())
O GBM4 foi o último modelo criado até agora, já excluímos as variáveis com near zero variance, excluímos variável ls_data, criamos nova features e treinamos com menos árvores com o objetivo de evitar o overthing. Percebemos que o GBM4 não teve uma melhora no valor do Rsquared, porém como excluímos algumas colunas podemos dizer que ele é o nosso melhor modelo pois garante um Rsquared similar aos anteriores e possui menos dados.
GBM com completed post sem “anormalidades”
Notamos anteriormente que temos algumas observações em que o completed.post é desconhecido. Além disso, temos valores acima de 1. Por acreditar que um valor maior que 1 na variável completed.post seja um erro na aquisição dos dados, iremos deletar essas observações. Também iremos deletar observações com NA na variável completed post pela mesma razão.
dados.treino$completed.post <- as.numeric(as.character(dados.treino$completed.post))
dados.valida$completed.post <- as.numeric(as.character(dados.valida$completed.post))
dados.treino <- filter(dados.treino, completed.post <= 1)
dados.valida <- filter(dados.valida, completed.post <= 1)
write.csv2(dados.treino, file = 'Dados/treino_4.csv', row.names = FALSE)
write.csv2(dados.valida, file = 'Dados/validacao_4.csv', row.names = FALSE)
# Importando arquivo no h2o
path.input <- "/home/rodolfo/Desktop/tfg/Dados/treino_4.csv"
dados.train <- h2o.importFile(path = path.input, destination_frame = "train.hex")
path.validacao <- "/home/rodolfo/Desktop/tfg/Dados/validacao_4.csv"
dados.validacao <- h2o.importFile(path = path.validacao, destination_frame = "validacao.hex")
# Coluna que se deseja prever
myY <- "completed.post"
# Coluna que deve ser ignorada pelo modelo
ignored_columns <- "completed.post"
myX <- setdiff(setdiff(names(dados.train), myY), ignored_columns)
# GBM
gbm_5 <- h2o.gbm(x = myX, build_tree_one_node = T,
y = myY,
training_frame = dados.train,
validation_frame = dados.validacao,
ntrees = 30,
max_depth = 6,
learn_rate = 0.1)
# Score de cada modelo
trainr2.gbm5 <- h2o.r2(gbm_5)
testr2.gbm5 <- h2o.r2(gbm_5, valid = TRUE)ggplot(data=toPlot, aes(x = modelo, y = Rsquared, fill = tipo)) +
geom_bar(stat="identity", position=position_dodge()) +
theme_classic() +
labs(title = "Comparando os modelos GBM") +
theme(axis.ticks = element_blank())
O modelo GBM5 apresentou uma melhora significativa. O Rsquared do treino ficou em 0.9987376 e da validação ficou em 0.9965823. Ao excluir valores “anormais” do dataset o modelo ficou menos confuso e com isso consegue acertar mais. É importante destacar que esse valor é bastante alto no mundo real.
Olhando mais de perto como se deu o treinamento temos:
As variáveis que mais contribuiram para a criação do modelo foram:
Mesmo com um valor de Rsquared alto, ainda é possível melhorar o modelo mas temos que ter mais cuidado para não causar overfitting.
GBM com imputation
As 5 variáveis que mais contribuem para a criação do modelo (figura anterior) são: completed, ttp, tsad, tries, tsls. Dessas 5 variáveis 2 possuem algumas observaçõe com valores NA/NULL são as variáveis tries e tsls. Tentando melhorar ainda mais o modelo iremos fazer uma imputation simples.
Para a imputation, o ideal seria criar um modelo que iria realizar uma predição dos valores faltantes. A gente poderia usar o Mice. Porém a titulo de demonstração irei utilizar o valor mais comum da coluna (MODA) para realizar a imputation nas colunas trie e tsls.
getmode <- function(v) {
uniqv <- unique(v)
uniqv[which.max(tabulate(match(v, uniqv)))]
}
# Imputation tsls
dados.treino$tsls <- as.numeric(as.character(dados.treino$tsls))
dados.valida$tsls <- as.numeric(as.character(dados.valida$tsls))
temp <- filter(dados.treino, tsls > 0)
dados.treino$tsls[is.na(dados.treino$tsls)] <- getmode(temp$tsls)
dados.valida$tsls[is.na(dados.valida$tsls)] <- getmode(temp$tsls)
# Imputation tries
dados.treino$tries <- as.numeric(as.character(dados.treino$tries))
dados.valida$tries <- as.numeric(as.character(dados.valida$tries))
temp <- filter(dados.treino, tries > 0)
dados.treino$tries[is.na(dados.treino$tries)] <- getmode(temp$tries)
dados.valida$tries[is.na(dados.valida$tries)] <- getmode(temp$tries)
write.csv2(dados.treino, file = 'Dados/treino_5.csv', row.names = FALSE)
write.csv2(dados.valida, file = 'Dados/validacao_5.csv', row.names = FALSE)
# Importando arquivo no h2o
path.input <- "/home/rodolfo/Desktop/tfg/Dados/treino_5.csv"
dados.train <- h2o.importFile(path = path.input, destination_frame = "train.hex")
path.validacao <- "/home/rodolfo/Desktop/tfg/Dados/validacao_5.csv"
dados.validacao <- h2o.importFile(path = path.validacao, destination_frame = "validacao.hex")
# Coluna que se deseja prever
myY <- "completed.post"
# Coluna que deve ser ignorada pelo modelo
ignored_columns <- "completed.post"
myX <- setdiff(setdiff(names(dados.train), myY), ignored_columns)
# GBM
gbm_6 <- h2o.gbm(x = myX, build_tree_one_node = T,
y = myY,
training_frame = dados.train,
validation_frame = dados.validacao,
ntrees = 30,
max_depth = 6,
learn_rate = 0.1)
# Score de cada modelo
trainr2.gbm6 <- h2o.r2(gbm_6)
testr2.gbm6 <- h2o.r2(gbm_6, valid = TRUE)ggplot(data=toPlot, aes(x = modelo, y = Rsquared, fill = tipo)) +
geom_bar(stat="identity", position=position_dodge()) +
theme_classic() +
labs(title = "Comparando os modelos GBM") +
theme(axis.ticks = element_blank())
O ganho entre o modelo 6 e 5 foi minimo, não sendo possível verificar visualmente. A diferença no conjunto de treino do Rsquared do modelo 6 para o 5 foi de -1.101028810^{-6}
É possível notar que o tsls subiu de importância se a gente comprar com o modelo passado.
Escolhemos o último modelo como sendo o melhor modelo dentre todos os modelos testados. Ele será o modelo que irá gerar a predição para o teste.
Realizando a predição
Depois de escolhido o modelo vamos prepara os dados do teste. Inicialmente deveremos criar a feature nova no dataset do teste.
O próximo passo é excluir todas as colunas que não estão presentes no modelo final user, revenue, units, ls.date
test <- read.csv("Dados/test_progress_predictor-4.csv")
test$data <- as.Date(as.character(test$ls.date), format = "%Y-%m-%d")
test$dia <- as.numeric(format(test$data, format = '%j'))
test$user <- NULL
test$revenue <- NULL
test$units <- NULL
test$ls.date <- NULL
test$data <- NULL
write.csv2(test, file = 'Dados/test.csv', row.names = FALSE)
# Carregando a tabela teste no h2o
path_test <- "/home/rodolfo/Desktop/tfg/Dados/test.csv"
data_test <- h2o.importFile(path = path_test, destination_frame = "test.hex")
# Realizando a predição
predicao = h2o.predict(object = gbm_6, newdata = data_test)
h2o.exportFile(predicao, path = "/home/rodolfo/Desktop/tfg/Dados/predicao2.csv", force = TRUE)
# Editando o arquivo de predição
predicao2 <- read.csv("Dados/predicao2.csv")
predicao2$predict <- as.character(predicao2$predict)
predicao2$predict <- gsub(",", ".", predicao2$predict)
predicao2$predict <- as.numeric(predicao2$predict)
write.csv2(predicao2$predict, file = 'Dados/predicao.csv', row.names = FALSE)Podemos notar que os valores da predição estão dentro do valor esperado (0-1). O que aumenta o indicio de que a nossa predição foi boa.
min(predicao2$predict)## [1] 0.1333333max(predicao2$predict)## [1] 1Além disso, podemo verificar que a predição apresenta um histograma bastante parecido do histograma no treino.
hist(predicao2$predict, main="Histograma Predição Completed Post",
xlab= "Completed Post")
hist(dados.treino$completed.post, main="Histograma Treino Completed Post",
xlab= "Completed Post")
Os dois histogramas estão bem similares o que aumenta o indicio de que o modelo é eficiente.