Challenge Project 03 - Warm Up: Predict Blood Donations¶
01 de abril, 2020
1. Descrição geral do problema¶
A doação de sangue existe há muito tempo. A primeira transfusão registrada com sucesso ocorreu entre dois cães em 1665, e o primeiro uso médico de sangue humano em uma transfusão ocorreu em 1818. Ainda hoje, o sangue doado permanece um recurso crítico durante emergências.
Nosso conjunto de dados é de um veículo móvel para doação de sangue em Taiwan. O Centro de Serviços de Transfusão de Sangue dirige-se a diferentes universidades e coleta sangue como parte de uma unidade de sangue. Queremos prever se um doador dará ou não sangue na próxima vez que o veículo chegar ao campus.
Acreditamos que é importante doar sangue. Bons sistemas orientados a dados para rastrear e prever doações e necessidades de suprimentos podem melhorar toda a cadeia de suprimentos, garantindo que mais pacientes recebam as transfusões de sangue de que precisam.
Nos Estados Unidos, a Cruz Vermelha Americana é um bom recurso para obter informações sobre doação de sangue. De acordo com o site :
- A cada dois segundos, alguém nos EUA precisa de sangue;
- Mais de 41.000 doações de sangue são necessárias todos os dias;
- Um total de 30 milhões de hemocomponentes são transfundidos a cada ano nos EUA;
- O sangue usado em uma emergência já está nas prateleiras antes que o evento ocorra;
- A doença das células falciformes afeta mais de 70.000 pessoas nos EUA. Aproximadamente 1.000 bebês nascem com a doença a cada ano. Os pacientes com células falciformes podem necessitar de transfusões sanguíneas frequentes ao longo da vida;
- Mais de 1,6 milhão de pessoas foram diagnosticadas com câncer no ano passado. Muitos deles precisarão de sangue, às vezes diariamente, durante o tratamento quimioterápico e;
- Uma única vítima de acidente de carro pode precisar de até 100 litros de sangue.
Para obter mais informações, consulte o site da Cruz Vermelha Americana.
Objetivo: dada a nossa missão, estamos interessados em utilizar a linguagem R para prever se um doador de sangue doará dentro de uma determinada janela de tempo. O objetivo é prever os valores da última coluna (Made Donation in March 2007), para deterimnar se ele / ela doou sangue em março de 2007.
Os dados são cortesia de Yeh, I-Cheng através do repositório UCI Machine Learning.
2. Carregando Dados¶
2.1 Importando bibliotecas necessárias¶
Vamos começar nosso projeto importanto todas as bilbiotecas necessárias para a realização das fases iniciais de exploração e transformação dos dados (Data Munging).
# Definindo a ocultação de warnings.
options(warn = -1)
# Caso não possua uma das bibliotecas importadas abaixo, a instale com um dos comandos a seguir:
install.packages(c(
'ggplot2',
'plyr',
'corrplot',
'caret',
'GGally',
'dplyr',
'e1071',
'data.table'
))
# Importando bibliotecas.
library(ggplot2)
library(plyr)
library(corrplot)
library(caret)
library(GGally)
library(dplyr)
library(e1071)
library(data.table)
2.2 Carregando Dados¶
# Importando os dados do dataset.
dataset <- read.table("/content/datasets/transfusion.data", sep = ",", header = T)
# Criando cópia do dataset.
data <- dataset
# Visualizando os primeiros registros do conjunto de dados.
head(data)
3. Data Munging¶
Antes de prosseguirmos, iremos trocar o nome das colunas para facilitar a análise nas próximas etapas.
# Alterando os nomes das colunas do dataset.
names(data) <- c(
"months_since_last_donation",
"frequency",
"total_blood_donated",
"months_since_first_donation",
"donated_blood"
)
# Visualizando os primeiros registros do conjunto de dados.
head(data)
Também iremos converter a varíavel donated_blood para o tipo factor.
# Alterando o tipo da variável donated_blood para o tipo factor.
data$donated_blood <- as.factor(data$donated_blood)
# Alterando o nome das classes da variável donated_blood.
levels(data$donated_blood) <- c('No', 'Yes')
# Visualizando os primeiros registros do conjunto de dados.
head(data)
# Verificando a existência de registros duplicados.
table(duplicated(data))
Existem 215 registros duplicados que deverão ser excluídos. Isto deve ser feito para que possamos evitar problemas com overfitting no processo de modelagem preditiva.
# Eliminando registros duplicados do dataset.
data <- data[!duplicated(data), ]
# Verificando a existência de registros duplicados.
table(duplicated(data))
Pronto! Eliminamos os registros duplicados do dataset.
As varíaveis months_since_last_donation e months_since_first_donation aparentam ser quantitativas discretas por representarem números de meses, mas foram carregadas como sendo do tipo numérico. Vamos verificar se existe algum valor frácionário dentro destes conjuntos de dados que justifique a utilização deste tipo de dado.
# Verificando os valores únicos existentes em cada variável do dataset antes da conversão do tipo de dado.
uniqValuesBefore <- sapply(data, function(v) {
sort(unique(v))
})
# Exibindo valores únicos das variáveis que irão ser convertidas.
uniqValuesBefore[c('months_since_last_donation', 'months_since_first_donation')]
Bom, não encontramos nenhum valor fracionário e por isso iremos converter as variáveis para o tipo de dado integer.
# Alterando o tipo da variável months_since_last_donation para o tipo factor.
data$months_since_last_donation <- as.integer(data$months_since_last_donation)
# Alterando o tipo da variável months_since_first_donation para o tipo factor.
data$months_since_first_donation <- as.integer(data$months_since_first_donation)
# Visualizando os primeiros registros do conjunto de dados.
head(data)
# Verificando os valores únicos existentes em cada variável do dataset após a conversão do tipo de dado.
uniqValuesAfter <- sapply(data, function(v) {
sort(unique(v))
})
# Exibindo valores únicos das variáveis que serão convertidas.
uniqValuesAfter[c('months_since_last_donation', 'months_since_first_donation')]
Por precaução, vamos nos certificar de que não perdemos nenhuma informação e que todos os dados do conjunto das variáveis convertidas permanecem iguais.
# Verificando se todos os valores únicos da variável months_since_first_donation permanecem iguais após a conversão
# do tipo de dado.
table(uniqValuesBefore$months_since_first_donation == uniqValuesAfter$months_since_first_donation)
# Verificando se todos os valores únicos da variável months_since_last_donation permanecem iguais após a conversão
# do tipo de dado.
table(uniqValuesBefore$months_since_last_donation == uniqValuesAfter$months_since_last_donation)
Perfeito, não perdemos nenhuma informação e já temos nosso dataset pronto para as próximas fases de análise.
4. Análise exploratória dos dados¶
Nesta etapa vamos buscar entender a disposição e as características dos dados dentro do dataset além de extrair insigths que possam auxiliar no processo de criação do modelo preditivo.
Segundo as documentações do DrivenData e da UCI Machine Learning Repository referente ao projeto, cada linha dos dados contém um registro, com as seguintes variáveis:
| Variável | Tipo | Descrição |
|---|---|---|
| months_since_last_donation | inteiro | este é o número de meses desde a doação mais recente do doador; |
| frequency | inteiro | este é o número total de doações que o doador fez; |
| total_blood_donated | inteiro | é a quantidade total de sangue que o doador doou em centímetros cúbicos; |
| months_since_first_donation | inteiro | este é o número de meses desde a primeira doação do doador e; |
| donated_blood (Target) | binário | é uma variável binária que representa se ele / ela doou sangue em março de 2007 (1 significa que doou sangue; 0 significa que não doou sangue). |
4.1 Visão geral dos dados¶
# Verificando os tipos das colunas carregadas do dataset.
glimpse(data)
Verificamos a existência de 5 variáveis numéricas e 533 observações dentro do dataset.
# Verificando a existência de valores NA no dataset.
print(sapply(data, function(v) {
anyNA(v)
}))
Não foi detectado nenhum valor NA dentro do conjunto de dados.
# Verificando o número de valores únicos presentes em cada uma das variáveis especificadas.
print(sapply(data, function(v) {
length(unique(v))
}))
Todas as variáveis preditoras possuem um número elevado de valores únicos. É interessante destacar que a variável frequency e total_blood_donated apresentam o mesmo número como resultado.
# Definindo as variáveis quantitativas dentro do dataset.
numVars <- colnames(data) != 'donated_blood'
# Calculando as estatísticas das colunas do dataset que representam variáveis quantitativas.
stats <- do.call(cbind, lapply(data[, numVars], summary))
# Determinando o valor do desvio-padrão de cada variável.
dataSD <- sapply(data[, numVars], sd)
# Inserindo os desvios-padrão no dataset.
stats <- as.data.frame(rbind(stats, sd = dataSD))
# Alterando nome das linhas.
rownames(stats) <- c('Min', 'Q1', 'Median', 'Mean', 'Q3', 'Max', 'Sd')
# Exibindo as estatísticas.
stats
Observamos que todas as variáveis possuem uma assimetria à direita.
Tendo isso em mente, vamos analisar o valor mediano dos registros agrupados pelas classes da variável alvo para cada variável peditora.
# Agrupando os registros do dataset segundo cada uma das classes da variável alvo e determinando o valor mediano de cada
# variável nos subconjuntos criados.
data %>%
group_by(donated_blood) %>%
summarise (
months_since_last_donation = median(months_since_last_donation),
frequency = median(frequency),
total_blood_donated = median(total_blood_donated),
months_since_first_donation = median(months_since_first_donation)
)
Olhando para a coluna months_since_last_donation podemos observar que os indivíudos que doaram em março tinham feito sua úlitma doação a menos tempo do que aqueles que não doaram (a diferença mediana é de 7 meses).
Notamos que a frequência dos indivíduos que doaram no mês de março é maior do que aqueles que não doaram (a diferença mediana é de 1 doação).
A coluna months_since_first_donation deixa claro que há uma diferença mediana de 6 meses desde a primeira doação do indivíduo que doou e o que não doou sangue em março. Ou seja, indivíduos que começaram a fazer doações de sangue a menos tempo parecem estar mais propensos a fazer a doação.
4.2 Explorando a distribuição de cada variável individualmente¶
4.2.1 Criando funções auxiliares para a criação de gráficos¶
Criaremos algumas funções para padronizar as plotagens de gráficos que efetuaremos.
# Definindo um função para criar gráficos de barra.
barPlot <- function(col, data, target = 'donated_blood') {
ggplot(data = data, aes(x = data[, col], fill = data[, target])) +
geom_bar() +
ggtitle(paste("Bar chart for variable:", col)) +
xlab(col) +
labs(fill = "Donated Blood in March") +
theme_bw()
}
# Definindo um função para criar gráficos de boxplot.
boxPlot <- function(col, data, target = 'donated_blood') {
ggplot(data = data, aes(x = data[, target], y = data[, col], fill = data[, target])) +
geom_boxplot() +
ggtitle(paste("Boxplot for variable:", col)) +
ylab(col) +
xlab("") +
labs(fill = "Donated Blood in March") +
theme_bw()
}
# Definindo um função para criar gráficos de densidade.
densityPlot <- function(col, data, target = 'donated_blood') {
ggplot(data = data, aes(x = data[, col], fill = data[, target])) +
geom_density(alpha = 0.85) +
ggtitle(paste("Density chart for variable:", col)) +
xlab(col) +
labs(fill = "Donated Blood in March") +
theme_bw()
}
4.2.2 Variável donated_blood¶
# Definindo o nome da variável a ser analisada.
col <- 'donated_blood'
# Criando um gráfico de barras para a variável especificada.
barPlot(col, data)
Vamos definir as proporções de cada classe dentro no conjunto de dados.
# Definindo a proporção de cada classe da variável donated_blood.
prop.table(table(data$donated_blood))
Concluímos que aproximadamente 28% dos registros indicam casos em que os indivíduos doaram sangue e 72% casos em que isto não ocorreu. Iremos analisar melhor esta questão na fase de modelagem preditiva.
4.2.3 Variável months_since_last_donation¶
# Definindo o nome da variável a ser analisada.
col <- 'months_since_last_donation'
# Criando um gráfico de barras para a variável especificada.
barPlot(col, data)
Este gráfico nos mostra que a medida que o número de meses desde a última doação aumenta, a tendência de não doar sangue também aumenta.
Vamos verificar quais são os números de meses passados desde a última doação mais frequentes entre os individuos que doaram sangue em março.
# Verificando a frequência dos números de meses.
data %>%
filter(data$donated_blood == 'Yes') %>%
group_by(months_since_last_donation) %>%
summarise(freq = n()) %>%
arrange(desc(freq)) %>%
head(5)
Concluímos que o número de doações de sangue em março é consideravelmente maior após 2 e 4 meses desde a última doação do indivíduo.
# Criando um gráfico de boxplot para a variável especificada.
boxPlot(col, data)
O gráfico de boxplot nos confirma que os índividuos que fizeram doações de sangue em março apresentam um valor mediano de meses desde sua última doação menor do que aqueles que não doaram.
4.2.4 Variável frequency¶
# Definindo o nome da variável a ser analisada.
col <- 'frequency'
# Criando um gráfico de barras para a variável especificada.
barPlot(col, data)
Vemos que há uma distribuição assimétrica à direita para este conjunto de dados e que esta assimetria é maior para o grupo de indivíduos que fizeram doações em março.
# Criando um gráfico de boxplot para a variável especificada.
boxPlot(col, data)
Vemos que o grupo que doou sangue, apresenta frequências de doações mais altas.
Agora vamos verificar se a diferença entre estes grupos é estatisticamente significativa aplicando o Teste hipótese T de Student. Definiremos nossas hipóteses da seguinte maneira:
| Teste de hipótese |
|---|
| H0: As médias das frequências dos individuos que doaram ou não sangue no mês de março são iguais. |
| Ha: As médias das frequências dos individuos que doaram ou não sangue no mês de março são diferentes. |
# Criando um teste T de Student para verificar se a diferença das médias dasfrequências entre os individuos que doaram
# ou não sangue em março é estatisticamente significativa.
t.test(data[data$donated_blood == 'No', 'frequency'], data[data$donated_blood == 'Yes', 'frequency'])
Conclusão: Há evidências suficientes, com um nível de significância de 0.05, para rejeitar a hipótese nula de que as médias das frequências dos individuos que doaram ou não sangue no mês de março são iguais.
4.2.5 Variável total_blood_donated¶
# Definindo o nome da variável a ser analisada.
col <- 'total_blood_donated'
# Criando um gráfico de barras para a variável especificada.
barPlot(col, data)
# Criando um gráfico de boxplot para a variável especificada.
boxPlot(col, data)
Observe atentamente os gráficos criados e os compare com os que foram gerados para a variável frequency. Notará que são iguais, mas que a escala dos dados é diferente. Isto nos fornece um indício de que total_blood_donated é múltipla da variável frequency.
4.2.6 Variável months_since_first_donation¶
# Definindo o nome da variável a ser analisada.
col <- 'months_since_first_donation'
# Criando um gráfico de barras para a variável especificada.
barPlot(col, data)
# Criando um gráfico de boxplot para a variável especificada.
boxPlot(col, data)
Os gráficos nos permitem inferir as mesmas informações obtidas anteriormente indicando que os índividuos que não doaram sangue em março apresentam um número de meses maior desde a sua primeira doação.
4.3 Analisando a correlação entre as variáveis¶
Nesta etapa desejamos verificar como as variáveis numéricas se correlacionam, ou seja, como uma variável ajuda a prever o valor de outra variável no dataset.
# Criando um pair plot para visualizar as correlações entre as variáveis.
data %>%
ggpairs(
aes(
color = donated_blood,
alpha = 0.7
),
diag = list(continuous = 'barDiag'),
lower = list(discrete = 'facetbar'),
columnLabels = c(
"Months since last donation",
"Frequency",
"Total blood donated",
"Months since first donation",
"Donated blood"
)
) + theme_bw()
Algo interessante de se notar neste gráfico é a perfeita correlação entre as variáveis frequency e total_blood_donated indicando que as duas carregam a mesma informação. Um possível explicação para isso poderia ser que em cada doação há um quantidade pré-especificada de litros de sangue que devem ser colhidos na doação. Iremos confirmar esta teoria em breve, mas já temos ciência de que devemos eliminar uma destas variáveis para evitar o overffitng.
Também há uma correlação moderada entre a variável months_since_first_donation e as variáveis frequency e total_blood_donated o que parece ser coerente com a ideia de que conforme o número de meses desde a primeira doação aumenta, cresce o número de doações pois o tempo para realizá-las é maior. Veremos como iremos tratar isso posteriormente.
O desbalanceamento entre os registros para cada uma das classes da variável alvo donated_blood também se tornou evidente, indicando que a maior parte dos indivíduos registrados no conjunto de dados não realizou uma doação de sangue no mês de março de 2007. Esse desequilíbrio entre as classes é mais um desafio que devemos ultrapassar.
Agora vamos investigar mais detalhadamente a força e a direção das correlações entre as variáveis numéricas do dataset.
# Verificando a correlação entre as variáveis numéricas do dataset.
corrplot(
corr = cor(data %>% select(-donated_blood)),
method = 'color',
addCoef.col = 'black',
type = 'upper',
tl.col = 'black',
diag = F
)
Note que como observamos anteriormente, as variáveis frequency e total_blood_donated carregam a mesma informação e por isso apresentam as mesmas correlações com as demais variáveis.
4.4 Analisando a multiplicidade entre as variáveis frequency e total_blood_donated¶
Finalmente vamos analisar esta relação! Inicialmente detectamos há existência desta multiplicidade, mas agora vamos determinar numericamente qual seu valor e em seguida buscaremos uma possível explicação para sua existência.
# Determinando o valor escalar entre as variáveis total_blood_donated e frequency.
unique(data$total_blood_donated / data$frequency)
Veja o que fizemos. Dividimos todos os valores da variável total_blood_donated pelas respectivas frequências com que estavam associadas, em seguida buscamos todos os valores únicos que foram gerados. E o resultado obtido foi o valor 250, mas o que isso significa?
Bom, isto mostra que cada doação feita por um indivíduo é sempre de 250 centímetros cubicos (ou 250 ml) de sangue. Interessante, não?
5. Features Selection¶
O processo de Feature Selection consistirá na eliminação da variável total_blood_donated do nosso conjunto de dados.
# Eliminando a variável total_blood_donated do dataset.
data$total_blood_donated <- NULL
6. Features Engineering¶
Nosso primeiro passo será tratar os outliers que existem em cada variável preditora agrupada pela variável a ser prevista. E para isto, vamos optar por excluir os registros que apresentam valores extremos.
# Determinando os limites superiores da variável months_since_first_donation para os grupos que doaram ou não doaram sangue.
upperLimitYes <- quantile(data[data$donated_blood == 'Yes', 'months_since_first_donation'], probs = c(.75)) +
1.5 * IQR(data[data$donated_blood == 'Yes', 'months_since_first_donation'])
upperLimitNo <- quantile(data[data$donated_blood == 'No', 'months_since_first_donation'], probs = c(.75)) +
1.5 * IQR(data[data$donated_blood == 'No', 'months_since_first_donation'])
# Removendo registros que ultrapassem o limite superior do subconjunto de dados aos quais pertecem.
data <- data[data$donated_blood == 'Yes' & data$months_since_first_donation < upperLimitYes |
data$donated_blood == 'No' & data$months_since_first_donation < upperLimitNo, ]
# Determinando os limites superiores da variável months_since_last_donation para os grupos que doaram ou não doaram sangue.
upperLimitYes <- quantile(data[data$donated_blood == 'Yes', 'months_since_last_donation'], probs = c(.75)) +
1.5 * IQR(data[data$donated_blood == 'Yes', 'months_since_last_donation'])
upperLimitNo <- quantile(data[data$donated_blood == 'No', 'months_since_last_donation'], probs = c(.75)) +
1.5 * IQR(data[data$donated_blood == 'No', 'months_since_last_donation'])
# Removendo registros que ultrapassem o limite superior do subconjunto de dados aos quais pertecem.
data <- data[data$donated_blood == 'Yes' & data$months_since_last_donation < upperLimitYes |
data$donated_blood == 'No' & data$months_since_last_donation < upperLimitNo, ]
# Determinando os limites superiores da variável frequency para os grupos que doaram ou não doaram sangue.
upperLimitYes <- quantile(data[data$donated_blood == 'Yes', 'frequency'], probs = c(.75)) +
1.5 * IQR(data[data$donated_blood == 'Yes', 'frequency'])
upperLimitNo <- quantile(data[data$donated_blood == 'No', 'frequency'], probs = c(.75)) +
1.5 * IQR(data[data$donated_blood == 'No', 'frequency'])
# Removendo registros que ultrapassem o limite superior do subconjunto de dados aos quais pertecem.
data <- data[data$donated_blood == 'Yes' & data$frequency < upperLimitYes |
data$donated_blood == 'No' & data$frequency < upperLimitNo, ]
Iremos aplicar a transformação BoxCox nas variáveis preditoras para eliminar a assimetria em seus dados e escalaremos seus valores entre 0 e 1.
# Definindo as variáveis que devem ser transformadas e o tipo de método que deve ser aplicado.
preProcValues <- preProcess(data[, colnames(data) != 'donated_blood'], method = "BoxCox")
# Realizando o pré-processamento dos dados.
data <- predict(preProcValues, data)
# Definindo as variáveis que devem ser transformadas e o tipo de método que deve ser aplicado.
preProcValues <- preProcess(data[, colnames(data) != 'donated_blood'], method = "range")
# Realizando o pré-processamento dos dados.
data <- predict(preProcValues, data)
# Visualizando as primeiras linhas do dataset.
head(data)
7. Análise Preditiva¶
7.1 Importando bibliotecas necessárias¶
# Caso não possua uma das bibliotecas importadas abaixo, a instale com um dos comandos a seguir:
install.packages(c(
'randomForest',
'C50',
'fastAdaboost',
'xgboost',
'DMwR',
'MLmetrics',
'neuralnet'
))
# Importando bibliotecas.
library(randomForest)
library(C50)
library(fastAdaboost)
library(xgboost)
library(DMwR)
library(MLmetrics)
library(neuralnet)
7.2 Criando dados de treino e de teste¶
Para iniciar a modelagem preditiva, iremos criar os dados de treino e de teste.
# Definindo um seed.
set.seed(100)
# Criando as partições com dados de treino e de teste.
inTrain <- createDataPartition(data$donated_blood, p = .90, list = F)
# Segmentando dados de treino e de teste por partição.
train <- data[inTrain, ]
test <- data[-inTrain, ]
# Verificando a proporção de registros para cada uma das classes da variável alvo no dataset de treino.
prop.table(table(train$donated_blood))
7.3 Criando funções de busca dos melhores parâmetros para os modelos a serem criados¶
Como não sabemos qual o algoritmo mais adequado para realizar as previsões para o nosso problema nem que valores utilizar em suas configurações, criaremos funções que gerem diferentes modelos com diferentes ajustes baseados nos seguintes algoritmos: Random Forest, C 5.0, Adaboost, XGboost e Neuralnet.
Adotando esta estratégia conseguiremos extrair a melhor performance de cada um dos algoritmos a serem implementados.
7.3.1 Modelo Random Forest¶
Note que está função também tem a capaciade de avaliar a importância de cada variável preditora a ser utilizada no modelo.
# Definindo uma função para gerar diferentes modelos com diferentes valores de parametrização baseados no algoritmo
# Random Forest.
getBetterRandomForestParameters <- function(train, f, test = NULL, positive = NULL, nTree = 1:100, nNode = 1:100,
importance = F, statusPrint = F) {
# Criando o dataframe para salvar os resultados dos modelos.
featuresRF <- data.frame()
# Define o número total de modelos a serem criados.
total <- length(nTree) * length(nNode)
# Capturando o nome da variável a ser prevista.
target <- as.character(f[[2]])
# Define uma varíavel auxiliar para permitir o acompanhamento do progresso na avaliação dos modelos criados.
count <- 0
for(t in nTree) {
for(n in nNode) {
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Cria o modelo Random Forest a ser avaliado.
model <- randomForest(
formula = f,
data = train,
ntree = t,
nodesize = n,
importance = importance
)
# Determina a Confusion Matrix para a avaliação de importância das variáveis preditoras ou para realizar
# previsões.
if(importance) {
# Computa a Confusion Matrix gerada a partir do modelo criado para determinar a importância das variáveis.
cm <- confusionMatrix(table(
data = model$y,
reference = model$predicted
),
positive = positive
)
# Armazena os parâmetros utilizados para criação do modelo e a acurácia obtida no dataframe.
featuresRF <- rbind(featuresRF, data.frame(
nodes = n,
nTree = t,
accuracy = unname(cm$overall['Accuracy'])
))
} else {
# Realizando as previsões com o modelo baseado no algoritmo Random Forest.
pred <- predict(model, test)
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(pred = pred, data = test[ , target]), positive = positive)
# Armazena os parâmetros utilizados para criação do modelo, a acurácia e o score da métrica Logloss
# obtidos no dataframe.
featuresRF <- rbind(featuresRF, data.frame(
nodes = n,
nTree = t,
accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(predict(model, test, type = 'prob')[, positive], as.integer(test[, target]) - 1)
))
}
# Incrementa o número de modelos avaliados.
count <- count + 1
# Imprime a porcetagem de progresso do treinamento e a melhor acurácia ou valor da métrica logloss já alcançada.
if(statusPrint) {
if(importance) {
print(paste(100 * count / total, '%, best accuracy: ', max(featuresRF$accuracy)))
} else {
print(paste(100 * count / total, '%, best LogLoss: ', min(featuresRF$logloss)))
}
}
}
}
# Retorna o dataframe com os resultados obtidos pelo treinamento de cada modelo.
featuresRF
}
7.3.2 Modelo C 5.0¶
# Definindo uma função para gerar diferentes modelos com diferentes valores de parametrização baseados no algoritmo C 5.0.
getBetterC50Parameters <- function(train, test, cost, f, positive, trials = 1:100, statusPrint = F) {
# Criando o dataframe para salvar os resultados dos modelos.
featuresC50 <- data.frame()
# Define o número total de modelos a serem criados.
total <- length(trials)
# Capturando o nome da variável a ser prevista.
target <- as.character(f[[2]])
# Define uma varíavel auxiliar para permitir o acompanhamento do progresso na avaliação dos modelos criados.
count <- 0
for(t in trials) {
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Criando o modelo baseado no algoritmo C 5.0.
model_c50 <- C5.0(
formula = f,
data = train,
trials = t,
rules = T,
cost = cost,
control = C5.0Control(
winnow = T,
noGlobalPruning = T,
earlyStopping = T
)
)
# Realizando as previsões com o modelo baseado no algoritmo C 5.0.
pred <- predict(model_c50, test)
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(pred = pred, data = test[ , target]), positive = positive)
# Armazena os parâmetros utilizados para criação do modelo, a acurácia e o score da métrica Logloss obtidos no
#dataframe.
featuresC50 <- rbind(featuresC50, data.frame(
trials = t,
accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(predict(model_c50, test, type = 'prob')[ , positive], as.integer(test[, target]) - 1)
))
# Incrementa o número de modelos avaliados.
count <- count + 1
# Imprime a porcetagem de progresso do treinamento e o melhor valor da métrica logloss já alcançado.
if(statusPrint) {
print(paste(100 * count / total, '%, best LogLoss: ', min(featuresC50$logloss)))
}
}
# Retorna o dataframe com os resultados obtidos pelo treinamento de cada modelo.
featuresC50
}
7.3.3 Modelo Adaboost¶
# Definindo uma função para gerar diferentes modelos com diferentes valores de parametrização baseados no algoritmo
# Adaboost.
getBetterAdaboostParameters <- function(train, test, f, positive, nIters = 1:100, treeDepth = 3, statusPrint = F) {
# Criando o dataframe para salvar os resultados dos modelos.
featuresAdaboost <- data.frame()
# Define o número total de modelos a serem criados.
total <- length(nIters) * length(treeDepth)
# Capturando o nome da variável a ser prevista.
target <- as.character(f[[2]])
# Define uma varíavel auxiliar para permitir o acompanhamento do progresso na avaliação dos modelos criados.
count <- 0
for(n in nIters) {
for(t in treeDepth) {
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Criando o modelo baseado no algoritmo Adaboost.
model_adaboost <- adaboost(
formula = f,
data = train,
nIter = n,
tree_depth = t
)
# Realizando as previsões com o modelo baseado no algoritmo Adaboost.
pred <- predict(model_adaboost, test, type = 'class')
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(pred = pred$class, data = test[ , target]), positive = positive)
# Armazena os parâmetros utilizados para criação do modelo, a acurácia e o score da métrica Logloss obtidos
# no dataframe.
featuresAdaboost <- rbind(featuresAdaboost, data.frame(
nIter = n,
treeDepth = t,
accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(predict(model_adaboost, test, type = 'raw')$votes[, 2], as.integer(test[, target]) - 1)
))
# Incrementa o número de modelos avaliados.
count <- count + 1
# Imprime a porcetagem de progresso do treinamento e o melhor valor da métrica logloss já alcançado.
if(statusPrint) {
print(paste(100 * count / total, '%, best LogLoss: ', min(featuresAdaboost$logloss)))
}
}
}
# Retorna o dataframe com os resultados obtidos pelo treinamento de cada modelo.
featuresAdaboost
}
7.3.4 Modelo XGboost¶
# Definindo uma função para gerar diferentes modelos com diferentes valores de parametrização baseados no algoritmo XGboost.
getBetterXGboostParameters <- function(train, trainTarget, test, testTarget, maxDepth = 1:10, nEta = seq(0.1, 1, 0.1),
nRounds = 1:100, threshold = 0.5, statusPrint = F) {
# Criando o dataframe para salvar os resultados dos modelos.
featuresXGboost <- data.frame()
# Define o número total de modelos a serem criados.
total <- length(maxDepth) * length(nEta) * length(nRounds)
# Define uma varíavel auxiliar para permitir o acompanhamento do progresso na avaliação dos modelos criados.
count <- 0
for(m in maxDepth) {
for(e in nEta) {
for(r in nRounds) {
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Criando o modelo baseado no algoritmo XGboost.
model_xgboost <- xgboost(
data = train, # Define as variáveis preditoras.
label = trainTarget, # Define a variável target.
max.depth = m, # Define o tamanho máximo da árvore.
eta = e, # Define a taxa de aprendizado do modelo.
nthread = 16, # Define o número de threads que devem ser usadas.
# Quanto maior for esse número, mais rápido será o treinamento.
nrounds = r, # Define o número de iterações.
objective = "binary:logistic", # Define que o modelo deve ser baseado em uma regressão
# logistica binária.
verbose = F, # Define a exibição da queda da taxa de erro durante o treinamento.
eval_metric = 'logloss', # Define a função de avaliação a ser utilizada.
maximize = F # Define que a pontuação da avaliação deve ser minimizada.
)
# Realizando as previsões com o modelo baseado no algoritmo XGboost.
pred <- predict(model_xgboost, test)
# Definindo o threshold.
for(th in threshold) {
# Classificando os resultados segundo o threshold especificado.
predClass <- ifelse(pred > th, 1, 0)
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(
pred = factor(predClass, levels = c(0, 1)),
data = factor(testTarget, levels = c(0, 1))
),
positive = '1'
)
# Armazena os parâmetros utilizados para criação do modelo, a acurácia e o score da métrica Logloss
# obtidos no dataframe.
featuresXGboost <- rbind(featuresXGboost, data.frame(
maxDepth = m,
th = th,
eta = e,
nRounds = r,
accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(as.numeric(pred), testTarget)
))
}
# Incrementa o número de modelos avaliados.
count <- count + 1
# Imprime a porcetagem de progresso do treinamento e a melhor acurácia já alcançada.
if(statusPrint) {
print(paste(100 * count / total, '%, best LogLoss: ', min(featuresXGboost$logloss)))
}
}
}
}
# Retorna o dataframe com os resultados obtidos pelo treinamento de cada modelo.
featuresXGboost
}
7.3.5 Modelo Neuralnet¶
# Definindo uma função para gerar diferentes modelos com diferentes valores de parametrização baseados no algoritmo
# Neuralnet.
getBetterNNParameters <- function(train, test, f, neurons = 1:100, thresholdModel = seq(0.05, 1, 0.05),
thresholdClass = 0.5, statusPrint = F) {
# Criando o dataframe para salvar os resultados dos modelos.
featuresNN <- data.frame()
# Define o número total de modelos a serem criados.
total <- length(neurons) * length(thresholdModel)
# Capturando o nome da variável a ser prevista.
target <- as.character(f[[2]])
# Define uma varíavel auxiliar para permitir o acompanhamento do progresso na avaliação dos modelos criados.
count <- 0
for(n in neurons) {
for(r in thresholdModel) {
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Criando o modelo baseado no algoritmo Neuralnet.
nn <- neuralnet(
formula = f,
data = train,
hidden = n,
act.fct = "logistic",
stepmax = 1e+08,
linear.output = FALSE,
threshold = r
)
# Captura score da acurácia e da métrica Logloss para o modelo criado.
metrics = tryCatch({
# Realiza a previsão para os dados de treino com o modelo criado.
pred <- predict(nn, test)
for(th in thresholdClass) {
# Classificando os resultados segundo o threshold especificado.
predClass <- ifelse(pred > th, 1, 0)
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(
pred = factor(predClass, levels = c(0, 1)),
data = factor(test[, target], levels = c(0, 1))
),
positive = '1'
)
# Adiciona a configuração e os resultados obtidos pelo modelo avaliado ao dataframe.
featuresNN <- rbind(featuresNN, data.frame(
n = n,
thresholdModel = r,
thresholdClass = th,
Accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(pred, test[, target])
))
}
}, error = function(e) {
# Caso a rede neural não consiga convergir, retorna o valor NA para o score da acurácia e
# da métrica Logloss para o modelo criado.
featuresNN <- rbind(featuresNN, data.frame(
n = n,
thresholdModel = r,
thresholdClass = th,
Accuracy = NA,
logloss = NA
))
})
# Incrementa o número de modelos avaliados.
count <- count + 1
# Imprime a porcetagem de progresso do treinamento e a melhor acurácia já alcançada.
if(statusPrint) {
print(paste(100 * count / total, '%, best LogLoss: ', min(featuresNN$logloss)))
}
}
}
# Eliminando resultados de modelos que não convergiram.
featuresNN <- featuresNN[!is.na(featuresNN$logloss), ]
# Retorna o dataframe com os resultados obtidos pelo treinamento de cada modelo.
featuresNN
}
7.4 Avaliando a importância das variáveis com o algoritmo Random Forest¶
Antes de iniciarmos a criação dos modelos propriamente dita, é interessante definirmos o quanto cada variável dentro do dataset ajuda a prever o valor da variável target.
Para fazermos isto, utilizaremos o algoritmo Random Forest para computar tais valores. Como não sabemos qual o ajuste de parâmetros do algoritmo é mais adequado para o nosso conjunto de dados, criaremos modelos que possuam de 1 a 100 árvores com 1 a 100 nós.
Salvaremos a acurárica de cada modelo em um Dataframe. Note que por ser um processo de treinamento que tende a demandar muito tempo para ser processado, salvaremos os resultados obtidos em um arquivo CSV que pode ser carregado com todos os resultados gerados pelo bloco de código a seguir.
# Gerando diferentes modelos baseados no algoritmo Random Forest para avaliar a importância das variáveis preditoras
# no conjunto de dados.
impFeaturesRF <- getBetterRandomForestParameters(data, f = donated_blood ~. , importance = T, statusPrint = T)
# Salvando dataframe com os resultados gerados em um arquivo .csv.
fwrite(impFeaturesRF, '/content/outputs/impFeaturesRF.csv')
Caso deseje pular a execução do bloco de código anterior, basta carregar os resultados já processados que estão salvos no arquivo CSV abaixo:
# Carregando dataframe com os resultados obtidos para cada modelo Random Forest criado.
impFeaturesRF <- fread('/content/outputs/impFeaturesRF.csv')
Imprimiremos os registros dos modelos que apresentaram a melhor acurácia.
# Imprimindo registros dos modelos que alcançaram a maior acurácia.
bestRF <- impFeaturesRF[impFeaturesRF$accuracy == max(impFeaturesRF$accuracy), ]
bestRF
Caso mais de um modelo apresente a maior acurácia registrada dentro do dataset, selecionaremos o primeiro que foi listado para ser utilizado nas etapas seguintes.
# Selecionando o primeiro registro dentro do dataframe.
bestRF <- bestRF[1,]
Recriaremos este modelo e imprimiremos suas estatísticas.
# Define um seed para permitir que o mesmo resultado do experimento seja reproduzível.
set.seed(100)
# Criando modelo.
model <- randomForest(
formula = donated_blood ~.,
data = data,
ntree = bestRF$nTree,
nodesize = bestRF$nodes,
importance = T
)
# Imprimindo o modelo.
model
Agora podemos plotar o modelo em um gráfico e verificar o nível de importância das variáveis do dataset para prever a variável alvo.
# Plotando gráfico para visualizar o nível de importância de cada variável no processo de predição da variável alvo.
v <- as.data.frame(varImpPlot(model, main = 'Predictor variables'))
Também podemos mensurar numericamente o quanto cada variável auxilia no processo de predição da variável alvo.
# Captura em ordem decrescente de nível de importância o nome das variáveis.
names <- rownames(v[order(v[, 'MeanDecreaseAccuracy'], decreasing = T),])
# Imprime o resultado.
v[order(v[, 'MeanDecreaseAccuracy'], decreasing = T),]
7.5 Criando modelos¶
7.5.1 Modelo Random Forest¶
# Gerando diferentes modelos baseados no algoritmo Random Forest e determinando sua acurácia e score para a métrica LogLoss.
featuresRF <- getBetterRandomForestParameters(
train = train,
test = test,
f = donated_blood ~. ,
positive = 'Yes',
statusPrint = T,
nTree = 1:200,
nNode = 1:200
)
# Salvando dataframe com os resultados gerados em um arquivo .csv.
fwrite(featuresRF, '/content/outputs/featuresRF.csv')
Caso deseje pular a execução do bloco de código anterior, basta carregar os resultados já processados que estão salvos no arquivo CSV abaixo:
# Carregando dataframe com os resultados obtidos para cada modelo Random Forest criado.
featuresRF <- fread('/content/outputs/featuresRF.csv')
Imprimiremos os registros dos modelos que apresentaram o menor score para a métrica Logloss.
# Imprimindo registros dos modelos que alcançaram o menor score para a métrica Logloss.
bestRF <- featuresRF[featuresRF$logloss == min(featuresRF$logloss), ]
bestRF
Caso mais de um modelo apresente o menor score para a métrica Logloss registrada dentro do dataset, selecionaremos o primeiro que foi listado para ser utilizado nas etapas seguintes.
# Selecionando o primeiro registro dentro do dataframe.
bestRF <- bestRF[1,]
Recriaremos este modelo e imprimiremos suas estatísticas.
# Define um seed para permitir que o mesmo resultado do experimento seja reproduzível.
set.seed(100)
# Criando modelo.
model_rf <- randomForest(
formula = donated_blood ~.,
data = train,
ntree = bestRF$nTree,
nodesize = bestRF$nodes
)
# Imprimindo o modelo.
model_rf
# Realizando as previsões com o modelo baseado no algoritmo Random Forest.
pred <- predict(model_rf, test)
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(pred = pred, data = test$donated_blood), positive = 'Yes')
# Visualizando a Confusion Matrix.
cm
Perfeito, nosso primeiro modelo foi criado! Vamos salvar os scores de sua acurácia e de sua métrica Logloss em um dataframe.
# Salvando scores das métricas analisadas em um dataframe.
scoreModels <- data.frame(
accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(predict(model_rf, test, type = 'prob')[, 'Yes'], as.integer(test$donated_blood) - 1),
row.names = 'randomForest'
)
7.5.2 Modelo C 5.0¶
# Definindo a matriz de custos a ser utilizada pelo modelo.
cost <- matrix(c(0, 0.75, 1, 0), nrow = 2, dimnames = list(c("No", "Yes"), c("No", "Yes")))
# Visualizando a matriz.
cost
# Gerando diferentes modelos baseados no algoritmo C 5.0 e determinando sua acurácia e score para a métrica LogLoss.
featuresC50 <- getBetterC50Parameters(
train = train,
test = test,
cost = cost,
f = donated_blood ~.,
positive = 'Yes',
statusPrint = T
)
# Salvando dataframe com os resultados gerados em um arquivo .csv.
fwrite(featuresC50, '/content/outputs/featuresC50.csv')
Caso deseje pular a execução do bloco de código anterior, basta carregar os resultados já processados que estão salvos no arquivo CSV abaixo:
# Carregando dataframe com os resultados obtidos para cada modelo C 5.0 criado.
featuresC50 <- fread('/content/outputs/featuresC50.csv')
Imprimiremos os registros dos modelos que apresentaram o menor score para a métrica Logloss.
# Imprimindo registros dos modelos que alcançaram o menor score para a métrica Logloss.
bestC50 <- featuresC50[featuresC50$logloss == min(featuresC50$logloss), ]
bestC50
Caso mais de um modelo apresente o menor score para a métrica Logloss registrada dentro do dataset, selecionaremos o primeiro que foi listado para ser utilizado nas etapas seguintes.
# Selecionando o primeiro registro dentro do dataframe.
bestC50 <- bestC50[1,]
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Criando o modelo baseado no algoritmo C 5.0.
model_c50 <- C5.0(
form = donated_blood ~.,
data = train,
trials = bestC50$trials,
rules = T,
cost = cost,
control = C5.0Control (
winnow = T,
noGlobalPruning = T,
earlyStopping = T
)
)
# Realizando as previsões com o modelo baseado no algoritmo C 5.0.
pred <- predict(model_c50, test)
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(pred = pred, data = test$donated_blood), positive = 'Yes')
# Visualizando a Confusion Matrix.
cm
# Salvando scores das métricas analisadas em um dataframe.
scoreModels <- rbind(scoreModels, data.frame(
accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(predict(model_c50, test, type = 'prob')[ , 'Yes'], as.integer(test$donated_blood) - 1),
row.names = 'C5.0'
))
7.5.3 Modelo Adaboost¶
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Gerando diferentes modelos baseados no algoritmo Adaboost e determinando sua acurácia e score para a métrica LogLoss.
featuresAdaboost <- getBetterAdaboostParameters(
train = train,
test = test,
f = donated_blood ~.,
positive = 'Yes',
statusPrint = T
)
# Salvando dataframe com os resultados gerados em um arquivo .csv.
fwrite(featuresAdaboost, '/content/outputs/featuresAdaboost.csv')
Caso deseje pular a execução do bloco de código anterior, basta carregar os resultados já processados que estão salvos no arquivo CSV abaixo:
# Carregando dataframe com os resultados obtidos para cada modelo Adaboost criado.
featuresAdaboost <- fread('/content/outputs/featuresAdaboost.csv')
Imprimiremos os registros dos modelos que apresentaram o menor score para a métrica Logloss.
# Imprimindo registros dos modelos que alcançaram o menor score para a métrica Logloss.
bestAdaboost <- featuresAdaboost[featuresAdaboost$logloss == min(featuresAdaboost$logloss), ]
bestAdaboost
Caso mais de um modelo apresente o menor score para a métrica Logloss registrada dentro do dataset, selecionaremos o primeiro que foi listado para ser utilizado nas etapas seguintes.
# Selecionando o primeiro registro dentro do dataframe.
bestAdaboost <- bestAdaboost[1,]
Recriaremos este modelo e imprimiremos suas estatísticas.
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Criando o modelo baseado no algoritmo Adaboost.
model_adaboost <- adaboost(
formula = donated_blood ~.,
data = train,
nIter = bestAdaboost$nIter
)
# Realizando as previsões com o modelo baseado no algoritmo Adaboost.
pred <- predict(model_adaboost, test, type = 'class')
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(pred = pred$class, data = test$donated_blood), positive = 'Yes')
# Visualizando a Confusion Matrix.
cm
# Salvando scores das métricas analisadas em um dataframe.
scoreModels <- rbind(scoreModels, data.frame(
accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(predict(model_adaboost, test, type = 'raw')$votes[, 2], as.integer(test$donated_blood) - 1),
row.names = 'adaboost'
))
7.5.4 Modelo XGboost¶
# Gerando diferentes modelos baseados no algoritmo Adaboost e determinando sua acurácia e score para a métrica LogLoss.
featuresXGboost <- getBetterXGboostParameters(
train = as.matrix(train %>% select(- donated_blood)),
trainTarget = as.integer(train$donated_blood) - 1,
test = as.matrix(test %>% select(- donated_blood)),
testTarget = as.integer(test$donated_blood) - 1,
maxDepth = 1:10,
nEta = seq(0.1, 1, 0.1),
nRounds = 1:100,
threshold = 0.5,
statusPrint = F
)
# Salvando dataframe com os resultados gerados em um arquivo .csv.
fwrite(featuresXGboost, '/content/outputs/featuresXGboost.csv')
Caso deseje pular a execução do bloco de código anterior, basta carregar os resultados já processados que estão salvos no arquivo CSV abaixo:
# Carregando dataframe com os resultados obtidos para cada modelo XGboost criado.
featuresXGboost <- fread('/content/outputs/featuresXGboost.csv')
Imprimiremos os registros dos modelos que apresentaram o menor score para a métrica Logloss.
# Imprimindo registros dos modelos que alcançaram o menor score para a métrica Logloss.
bestXGboost <- featuresXGboost[featuresXGboost$logloss == min(featuresXGboost$logloss), ]
bestXGboost
Caso mais de um modelo apresente o menor score para a métrica Logloss registrada dentro do dataset, selecionaremos o primeiro que foi listado para ser utilizado nas etapas seguintes.
# Selecionando o primeiro registro dentro do dataframe.
bestXGboost <- bestXGboost[1,]
Recriaremos este modelo e imprimiremos suas estatísticas.
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Criando o modelo baseado no algoritmo Neuralnet.
model_xgboost <- xgboost(
data = as.matrix(train %>% select(- donated_blood)) , # Define as variáveis preditoras.
label = as.integer(train$donated_blood) - 1, # Define a variável target.
max.depth = bestXGboost$maxDepth, # Define o tamanho máximo da árvore.
eta = bestXGboost$eta, # Define a taxa de aprendizado do modelo.
nthread = 16, # Define o número de threads que devem ser usadas.
# Quanto maior for esse número, mais rápido será o treinamento.
nrounds = bestXGboost$nRounds, # Define o número de iterações.
objective = "binary:logistic", # Define que o modelo deve ser baseado em uma regressão logistica binária.
verbose = T, # Define a exibição da queda da taxa de erro durante o treinamento.
eval_metric = 'logloss', # Define a função de avaliação a ser utilizada.
maximize = F # Define que a pontuação da avaliação deve ser minimizada.
)
# Realizando as previsões com o modelo baseado no algoritmo Neuralnet.
pred <- predict(model_xgboost, as.matrix(test %>% select(- donated_blood)))
# Definindo o threshold.
th <- bestXGboost$th
# Classificando os resultados segundo o threshold especificado.
predClass <- ifelse(pred > th, 1, 0)
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(pred = predClass, data = as.integer(test$donated_blood) - 1), positive = '1')
# Visualizando a Confusion Matrix.
cm
# Salvando scores das métricas analisadas em um dataframe.
scoreModels <- rbind(scoreModels, data.frame(
accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(as.numeric(pred), as.matrix(as.integer(test$donated_blood) - 1)),
row.names = 'XGboost'
))
7.5.5 Modelo Neuralnet¶
# Gerando diferentes modelos baseados no algoritmo Neuralnet e determinando sua acurácia e score para a métrica LogLoss.
featuresNN <- getBetterNNParameters(
train = train %>% mutate(donated_blood = as.integer(train$donated_blood) - 1),
test = test %>% mutate(donated_blood = as.integer(test$donated_blood) - 1),
f = donated_blood ~.,
statusPrint = T
)
# Salvando dataframe com os resultados gerados em um arquivo .csv.
fwrite(featuresNN, '/content/outputs/featuresNN.csv')
Caso deseje pular a execução do bloco de código anterior, basta carregar os resultados já processados que estão salvos no arquivo CSV abaixo:
# Carregando dataframe com os resultados obtidos para cada modelo Neuralnet criado.
featuresNN <- fread('/content/outputs/featuresNN.csv')
Imprimiremos os registros dos modelos que apresentaram o menor score para a métrica Logloss.
# Imprimindo registros dos modelos que alcançaram o menor score para a métrica Logloss.
bestNN <- featuresNN[featuresNN$logloss == min(featuresNN$logloss), ]
bestNN
Caso mais de um modelo apresente o menor score para a métrica Logloss registrada dentro do dataset, selecionaremos o primeiro que foi listado para ser utilizado nas etapas seguintes.
# Selecionando o primeiro registro dentro do dataframe.
bestNN <- bestNN[1,]
Recriaremos este modelo e imprimiremos suas estatísticas.
# Define um seed para permitir que os mesmos resultados dos experimentos sejam reproduzíveis.
set.seed(100)
# Criando o modelo baseado no algoritmo Neuralnet.
nn <- neuralnet(
formula = donated_blood ~.,
data = train %>% mutate(donated_blood = as.integer(train$donated_blood) - 1),
hidden = bestNN$n,
act.fct = "logistic",
stepmax = 1e+08,
linear.output = FALSE,
threshold = bestNN$thresholdModel
)
# Realizando as previsões com o modelo baseado no algoritmo Neuralnet.
pred <- predict(nn, test %>% mutate(donated_blood = as.integer(test$donated_blood) - 1))
# Definindo o threshold.
th <- bestNN$thresholdClass
# Classificando os resultados segundo o threshold especificado.
predClass <- ifelse(pred > th, 1, 0)
# Criando a Confusion Matrix a partir das previsões.
cm <- confusionMatrix(table(
pred = predClass,
data = as.integer(test$donated_blood) - 1
),
positive = '1'
)
# Visualizando a Confusion Matrix.
cm
# Salvando scores das métricas analisadas em um dataframe.
scoreModels <- rbind(scoreModels, data.frame(
accuracy = unname(cm$overall['Accuracy']),
logloss = LogLoss(pred, as.integer(test$donated_blood) - 1),
row.names = 'Neuralnet'
))
7.6 Determinando o melhor modelo¶
Determinaremos qual modelo teve o melhor desempenho para o conjunto de dados de teste a partir do score da métrica LogLoss.
A métrica LogLoss quantifica a precisão de um classificador penalizando classificações falsas. Quando minimizamos seu score estamos basicamente maximizando a precisão do modelo. Ou seja, o modelo que apresentar o menor valor para esta métrica será aquele que irá classificar corretamente a maior proporção indivíduos que doaram sangue em março de 2007.
# Exibindo dataframe com as métricas de performance dos modelos treinados.
scoreModels
# Determinando o modelo que teve o melhor score para a métrica Logloss.
scoreModels[scoreModels$logloss == min(scoreModels$logloss), ]
Por fim, concluímos que o algoritmo que obteve a melhor performance para os critérios que adotamos foi o Random Forest.
Entre em contato comigo!¶
Caso tenha alguma dúvida, sugestão ou apenas queira trocar uma ideia sobre este projeto, não hesite em entrar em contato comigo!
