A regressão logística pode ser utilizada para classificar observações em decorrência de outras variáveis. Este é um exemplo com a base de dados do minha dissertação de mestrado.
# Pacotes
library(readxl) # leitura da base de dados
library(tidyverse) # manipulação de dados
library(caret) # ml workflow facilitado
setwd("~/Mestrado/Artigo") # define o diretório de trabalho
base_completa <- read_excel("base.xlsx") # lê a base de dados
set.seed(123) # Padronizar para replicação de resultado
base <- base_completa[,c(2, 85:89, 91:95)] # seleciona só os escores das escalas
colnames(base) <- c('grupo',
'preocupacao', 'controle', 'curiosidade', 'confianca', 'cooperacao',
'colaboration', 'task', 'engaging', 'emotional', 'open') # nomeia as colunas
base <- na.omit(base) # remove possíveis NAs
head(base)
## # A tibble: 6 x 11
## grupo preocupacao controle curiosidade confianca cooperacao colaboration
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 4 4.33 3.5 4.33 4 4
## 2 1 4.5 4.67 4 4.83 4.67 4.29
## 3 1 4.67 3.5 4.67 4 4.5 4.43
## 4 1 4.17 4 4.33 4.83 4.67 4.29
## 5 1 4.17 4.33 4.83 4.33 4.67 4.43
## 6 1 3.67 3 3.83 3.17 3.33 4
## # ... with 4 more variables: task <dbl>, engaging <dbl>, emotional <dbl>,
## # open <dbl>
Com a base de dados pronta, é preciso dividir entre teste e treinamento.
training.samples <- base$grupo %>% createDataPartition(p = 0.8, list = FALSE) # divisão 80/20
train.data <- base[training.samples, ]
test.data <- base[-training.samples, ]
Agora, precisamos ajustar o modelo. Neste exercício, utilizaremos todas as variáveis da base de dados.
model <- glm(grupo ~ ., data = train.data, family = binomial) # binomial é característica dicotômica
summary(model)
##
## Call:
## glm(formula = grupo ~ ., family = binomial, data = train.data)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.37008 -0.80024 0.05899 0.83393 2.13106
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -11.8999 3.0099 -3.954 7.7e-05 ***
## preocupacao 1.2609 0.4551 2.770 0.00560 **
## controle -0.3481 0.4995 -0.697 0.48589
## curiosidade 0.4362 0.4592 0.950 0.34212
## confianca 0.2627 0.4894 0.537 0.59148
## cooperacao -0.2772 0.4979 -0.557 0.57773
## colaboration -0.5427 0.5476 -0.991 0.32163
## task 1.9012 0.5975 3.182 0.00146 **
## engaging -0.5584 0.3729 -1.498 0.13425
## emotional 0.6678 0.3534 1.890 0.05877 .
## open 0.2071 0.4258 0.486 0.62672
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 221.81 on 159 degrees of freedom
## Residual deviance: 160.15 on 149 degrees of freedom
## AIC: 182.15
##
## Number of Fisher Scoring iterations: 5
Note que:
Agora é hora de fazer predições com o modelo. Utilizaremos a base de dados para teste nesta parte do exercício.
Primeiro, geraremos uma lista de elementos para cada observação, chamada probabilities
. Nela, estará a estimativa gerada pelo modelo.
probabilities <- model %>% predict(test.data, type = "response")
Depois, criaremos as classes desta predição. Como valor de corte, utilizaremos 0.5
. Isto significa que em todos os casos que a probabilities
for maior que 0.5
, a classe predita será 1
(grupo de aprendizes).
predicted.classes <- ifelse(probabilities > 0.5, 1, 0)
Agora, é necessário estimar a acurácia do modelo, ou seja: o quanto que o modelo acerta e o quanto erra.
mean(predicted.classes == test.data$grupo)
## [1] 0.8
Com 80% de acurácia, este é um modelo bem ajustado.
Durante o estudo, percebemos que existia uma diferença de idade entre o grupo de aprendizes e não aprendizes. Por conta disso, foi decidido retirar essa variável para criação deste modelo. Agora, incluiremos esta variável para verificar sua influência na acurácia do modelo.
base_idade <- base_completa[,c(2, 3, 85:89, 91:95)] # seleciona só os escores das escalas
colnames(base_idade) <- c('grupo', 'idade',
'preocupacao', 'controle', 'curiosidade', 'confianca', 'cooperacao',
'colaboration', 'task', 'engaging', 'emotional', 'open') # nomeia as colunas
base_idade <- na.omit(base_idade) # remove possíveis NAs
# Dividir a base de dados em treinamento e teste
training.samples_idade <- base_idade$grupo %>% createDataPartition(p = 0.8, list = FALSE) # divisão 80/20
train.data_idade <- base_idade[training.samples_idade, ]
test.data_idade <- base_idade[-training.samples_idade, ]
model_idade <- glm(grupo ~ ., data = train.data_idade, family = binomial) # binomial é característica dicotômica
summary(model_idade)
##
## Call:
## glm(formula = grupo ~ ., family = binomial, data = train.data_idade)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.4583 -0.5766 -0.1424 0.6184 1.8605
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -35.142742 6.138844 -5.725 1.04e-08 ***
## idade 1.404289 0.276060 5.087 3.64e-07 ***
## preocupacao 1.072180 0.464026 2.311 0.0209 *
## controle -0.441103 0.561807 -0.785 0.4324
## curiosidade 0.118429 0.514823 0.230 0.8181
## confianca 0.617056 0.559987 1.102 0.2705
## cooperacao -0.165439 0.582835 -0.284 0.7765
## colaboration 0.407686 0.627918 0.649 0.5162
## task 1.548839 0.666668 2.323 0.0202 *
## engaging -0.132468 0.416278 -0.318 0.7503
## emotional -0.009486 0.405913 -0.023 0.9814
## open -0.079831 0.511073 -0.156 0.8759
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 220.36 on 158 degrees of freedom
## Residual deviance: 127.53 on 147 degrees of freedom
## AIC: 151.53
##
## Number of Fisher Scoring iterations: 5
Percebemos que a idade pode trazer melhora significante para o modelo. Agora iremos verificar qual a acurácia considerando a idade:
probabilities_idade <- model_idade %>% predict(test.data_idade, type = "response")
predicted.classes_idade <- ifelse(probabilities_idade > 0.5, 1, 0)
# Acurácia do modelo
mean(predicted.classes_idade == test.data_idade$grupo)
## [1] 0.8717949
Houve melhora significativa do modelo.