Regressão Logística

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>

Dividir a base de dados

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:

Fazer Predições

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)

Acurácia do Modelo

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.

Acurácia com idade

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.