O objetivo desse laboratório é utilizar a regressão logística com um conjunto de variáveis explicativas (com no mínimo 4 variáveis).

Antes de tudo gostaríamos de fazer um descritivo das variáveis.

Carregando os dados

s_dating <- read_csv("5-regressao/speed-dating/speed-dating2.csv")
## Rows: 4918 Columns: 44
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (4): field, from, career, dec
## dbl (40): iid, gender, order, pid, int_corr, samerace, age_o, age, race, spo...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
glimpse(s_dating)
## Rows: 4,918
## Columns: 44
## $ iid      <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3…
## $ gender   <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ order    <dbl> 4, 3, 10, 5, 7, 6, 1, 2, 8, 9, 10, 9, 6, 1, 3, 2, 7, 8, 4, 5,…
## $ pid      <dbl> 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 11, 12, 13, 14, 15, 1…
## $ int_corr <dbl> 0.14, 0.54, 0.16, 0.61, 0.21, 0.25, 0.34, 0.50, 0.28, -0.36, …
## $ samerace <dbl> 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1…
## $ age_o    <dbl> 27, 22, 22, 23, 24, 25, 30, 27, 28, 24, 27, 22, 22, 23, 24, 2…
## $ age      <dbl> 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 24, 24, 24, 24, 24, 2…
## $ field    <chr> "Law", "Law", "Law", "Law", "Law", "Law", "Law", "Law", "Law"…
## $ race     <dbl> 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2…
## $ from     <chr> "Chicago", "Chicago", "Chicago", "Chicago", "Chicago", "Chica…
## $ career   <chr> "lawyer", "lawyer", "lawyer", "lawyer", "lawyer", "lawyer", "…
## $ sports   <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3…
## $ tvsports <dbl> 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 8…
## $ exercise <dbl> 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7…
## $ dining   <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10,…
## $ museums  <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 5…
## $ art      <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 5…
## $ hiking   <dbl> 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8…
## $ gaming   <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 4…
## $ clubbing <dbl> 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 5…
## $ reading  <dbl> 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 10, 10, 10, 10, 10, 10, 10, 10,…
## $ tv       <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 8…
## $ theater  <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 7…
## $ movies   <dbl> 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 8, 8, 8, 8, 8, 8, 8, …
## $ concerts <dbl> 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 7, 7, 7, 7, 7, 7, 7, …
## $ music    <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 5…
## $ shopping <dbl> 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8…
## $ yoga     <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 7…
## $ attr     <dbl> 6, 7, 5, 7, 5, 4, 7, 4, 7, 5, 5, 8, 5, 7, 6, 8, 7, 5, 7, 6, 7…
## $ sinc     <dbl> 9, 8, 8, 6, 6, 9, 6, 9, 6, 6, 7, 5, 8, 9, 8, 7, 5, 8, 6, 7, 9…
## $ intel    <dbl> 7, 7, 9, 8, 7, 7, 7, 7, 8, 6, 8, 6, 9, 7, 7, 8, 9, 7, 8, 8, 1…
## $ fun      <dbl> 7, 8, 8, 7, 7, 4, 4, 6, 9, 8, 4, 6, 6, 6, 9, 3, 6, 5, 9, 7, 7…
## $ amb      <dbl> 6, 5, 5, 6, 6, 6, 6, 5, 8, 10, 6, 9, 3, 5, 7, 6, 7, 9, 4, 9, …
## $ shar     <dbl> 5, 6, 7, 8, 6, 4, 7, 6, 8, 8, 3, 6, 4, 7, 8, 2, 9, 5, 5, 8, 9…
## $ like     <dbl> 7, 7, 7, 7, 6, 6, 6, 6, 7, 6, 6, 7, 6, 7, 8, 6, 8, 5, 5, 8, 8…
## $ prob     <dbl> 6, 5, NA, 6, 6, 5, 5, 7, 7, 6, 4, 3, 7, 8, 6, 5, 7, 6, 6, 7, …
## $ match_es <dbl> 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, N…
## $ attr3_s  <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ sinc3_s  <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ intel3_s <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ fun3_s   <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ amb3_s   <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ dec      <chr> "yes", "yes", "yes", "yes", "yes", "no", "yes", "no", "yes", …
summary(s_dating)
##       iid            gender          order            pid     
##  Min.   :  1.0   Min.   :0.000   Min.   : 1.00   Min.   :  1  
##  1st Qu.: 88.0   1st Qu.:0.000   1st Qu.: 4.00   1st Qu.: 88  
##  Median :273.0   Median :1.000   Median : 9.00   Median :273  
##  Mean   :274.7   Mean   :0.501   Mean   : 9.26   Mean   :275  
##  3rd Qu.:431.0   3rd Qu.:1.000   3rd Qu.:14.00   3rd Qu.:431  
##  Max.   :552.0   Max.   :1.000   Max.   :22.00   Max.   :552  
##                                                  NA's   :10   
##     int_corr          samerace          age_o            age       
##  Min.   :-0.7300   Min.   :0.0000   Min.   :18.00   Min.   :18.00  
##  1st Qu.:-0.0300   1st Qu.:0.0000   1st Qu.:23.00   1st Qu.:23.00  
##  Median : 0.2100   Median :0.0000   Median :25.00   Median :25.00  
##  Mean   : 0.1905   Mean   :0.4063   Mean   :25.79   Mean   :25.78  
##  3rd Qu.: 0.4300   3rd Qu.:1.0000   3rd Qu.:28.00   3rd Qu.:28.00  
##  Max.   : 0.9000   Max.   :1.0000   Max.   :39.00   Max.   :39.00  
##  NA's   :72                         NA's   :61      NA's   :52     
##     field                race           from              career         
##  Length:4918        Min.   :1.000   Length:4918        Length:4918       
##  Class :character   1st Qu.:2.000   Class :character   Class :character  
##  Mode  :character   Median :2.000   Mode  :character   Mode  :character  
##                     Mean   :2.731                                        
##                     3rd Qu.:4.000                                        
##                     Max.   :6.000                                        
##                     NA's   :20                                           
##      sports          tvsports         exercise          dining      
##  Min.   : 1.000   Min.   : 1.000   Min.   : 1.000   Min.   : 1.000  
##  1st Qu.: 5.000   1st Qu.: 2.000   1st Qu.: 5.000   1st Qu.: 7.000  
##  Median : 7.000   Median : 4.000   Median : 6.000   Median : 8.000  
##  Mean   : 6.396   Mean   : 4.527   Mean   : 6.118   Mean   : 7.687  
##  3rd Qu.: 8.000   3rd Qu.: 7.000   3rd Qu.: 8.000   3rd Qu.: 9.000  
##  Max.   :10.000   Max.   :10.000   Max.   :10.000   Max.   :10.000  
##  NA's   :36       NA's   :36       NA's   :36       NA's   :36      
##     museums            art             hiking           gaming     
##  Min.   : 0.000   Min.   : 0.000   Min.   : 0.000   Min.   : 0.00  
##  1st Qu.: 6.000   1st Qu.: 5.000   1st Qu.: 4.000   1st Qu.: 2.00  
##  Median : 7.000   Median : 7.000   Median : 6.000   Median : 4.00  
##  Mean   : 6.876   Mean   : 6.595   Mean   : 5.768   Mean   : 4.02  
##  3rd Qu.: 8.000   3rd Qu.: 8.000   3rd Qu.: 8.000   3rd Qu.: 6.00  
##  Max.   :10.000   Max.   :10.000   Max.   :10.000   Max.   :14.00  
##  NA's   :36       NA's   :36       NA's   :36       NA's   :36     
##     clubbing         reading             tv           theater     
##  Min.   : 0.000   Min.   : 1.000   Min.   : 1.00   Min.   : 0.00  
##  1st Qu.: 4.000   1st Qu.: 7.000   1st Qu.: 3.00   1st Qu.: 5.00  
##  Median : 6.000   Median : 8.000   Median : 6.00   Median : 7.00  
##  Mean   : 5.726   Mean   : 7.645   Mean   : 5.29   Mean   : 6.72  
##  3rd Qu.: 8.000   3rd Qu.: 9.000   3rd Qu.: 7.00   3rd Qu.: 8.00  
##  Max.   :10.000   Max.   :13.000   Max.   :10.00   Max.   :10.00  
##  NA's   :36       NA's   :36       NA's   :36      NA's   :36     
##      movies         concerts          music           shopping     
##  Min.   : 0.00   Min.   : 0.000   Min.   : 1.000   Min.   : 1.000  
##  1st Qu.: 7.00   1st Qu.: 6.000   1st Qu.: 7.000   1st Qu.: 3.000  
##  Median : 8.00   Median : 7.000   Median : 8.000   Median : 6.000  
##  Mean   : 7.98   Mean   : 6.824   Mean   : 7.781   Mean   : 5.484  
##  3rd Qu.: 9.00   3rd Qu.: 8.000   3rd Qu.: 9.000   3rd Qu.: 7.000  
##  Max.   :10.00   Max.   :10.000   Max.   :10.000   Max.   :10.000  
##  NA's   :36      NA's   :36       NA's   :36       NA's   :36      
##       yoga             attr             sinc            intel       
##  Min.   : 0.000   Min.   : 0.000   Min.   : 0.000   Min.   : 0.000  
##  1st Qu.: 2.000   1st Qu.: 5.000   1st Qu.: 6.000   1st Qu.: 6.000  
##  Median : 4.000   Median : 6.000   Median : 7.000   Median : 7.000  
##  Mean   : 4.212   Mean   : 6.064   Mean   : 7.054   Mean   : 7.266  
##  3rd Qu.: 6.000   3rd Qu.: 7.000   3rd Qu.: 8.000   3rd Qu.: 8.000  
##  Max.   :10.000   Max.   :10.000   Max.   :10.000   Max.   :10.000  
##  NA's   :36       NA's   :118      NA's   :161      NA's   :166     
##       fun              amb              shar            like       
##  Min.   : 0.000   Min.   : 0.000   Min.   : 0.00   Min.   : 0.000  
##  1st Qu.: 5.000   1st Qu.: 6.000   1st Qu.: 4.00   1st Qu.: 5.000  
##  Median : 6.000   Median : 7.000   Median : 5.00   Median : 6.000  
##  Mean   : 6.289   Mean   : 6.697   Mean   : 5.32   Mean   : 6.051  
##  3rd Qu.: 8.000   3rd Qu.: 8.000   3rd Qu.: 7.00   3rd Qu.: 7.000  
##  Max.   :10.000   Max.   :10.000   Max.   :10.00   Max.   :10.000  
##  NA's   :197      NA's   :421      NA's   :643     NA's   :122     
##       prob           match_es         attr3_s          sinc3_s      
##  Min.   : 0.000   Min.   : 0.000   Min.   : 3.000   Min.   : 3.000  
##  1st Qu.: 4.000   1st Qu.: 2.000   1st Qu.: 7.000   1st Qu.: 7.000  
##  Median : 5.000   Median : 3.000   Median : 7.000   Median : 8.000  
##  Mean   : 5.017   Mean   : 3.169   Mean   : 7.077   Mean   : 7.994  
##  3rd Qu.: 7.000   3rd Qu.: 4.000   3rd Qu.: 8.000   3rd Qu.: 9.000  
##  Max.   :10.000   Max.   :10.000   Max.   :10.000   Max.   :10.000  
##  NA's   :156      NA's   :460      NA's   :2874     NA's   :2874    
##     intel3_s          fun3_s           amb3_s          dec           
##  Min.   : 4.000   Min.   : 3.000   Min.   : 3.00   Length:4918       
##  1st Qu.: 8.000   1st Qu.: 7.000   1st Qu.: 7.00   Class :character  
##  Median : 8.000   Median : 8.000   Median : 8.00   Mode  :character  
##  Mean   : 8.207   Mean   : 7.573   Mean   : 7.59                     
##  3rd Qu.: 9.000   3rd Qu.: 9.000   3rd Qu.: 9.00                     
##  Max.   :10.000   Max.   :10.000   Max.   :10.00                     
##  NA's   :2874     NA's   :2874     NA's   :2874

Descrição das variavéis

cat("Descrição das variáveis:\n")
## Descrição das variáveis:
cat("iid: id do participante p1 no encontro\n")
## iid: id do participante p1 no encontro
cat("gender: sexo do p1, 0 = mulher, 1 = homem\n")
## gender: sexo do p1, 0 = mulher, 1 = homem
cat("order: dos vários encontros realizados em uma noite, esse foi o n-ésimo, segundo essa variável\n")
## order: dos vários encontros realizados em uma noite, esse foi o n-ésimo, segundo essa variável
cat("pid: id do participante p2\n")
## pid: id do participante p2
cat("int_corr: correlação entre os interesses de p1 e p2\n")
## int_corr: correlação entre os interesses de p1 e p2
cat("samerace: p1 e p2 são da mesma raça? 1 = sim, 0 = não\n")
## samerace: p1 e p2 são da mesma raça? 1 = sim, 0 = não
cat("age_o: idade de p2\n")
## age_o: idade de p2
cat("age: idade de p1\n")
## age: idade de p1
cat("field: campo de estudo de p1\n")
## field: campo de estudo de p1
cat("race: raça de p1. O código é Black/African American=1; European/Caucasian-American=2; Latino/Hispanic American=3; Asian/Pacific Islander/Asian-American=4; Native American=5; Other=6\n")
## race: raça de p1. O código é Black/African American=1; European/Caucasian-American=2; Latino/Hispanic American=3; Asian/Pacific Islander/Asian-American=4; Native American=5; Other=6
cat("from: de onde p1 é\n")
## from: de onde p1 é
cat("career: que carreira p1 quer seguir\n")
## career: que carreira p1 quer seguir
cat("sports, tvsports, exercise, dining, museums, art, hiking, gaming, clubbing, reading, tv, theater, movies, concerts, music, shopping, yoga: De 1 a 10, quão interessado p1 é em cada uma dessas atividades.\n")
## sports, tvsports, exercise, dining, museums, art, hiking, gaming, clubbing, reading, tv, theater, movies, concerts, music, shopping, yoga: De 1 a 10, quão interessado p1 é em cada uma dessas atividades.
cat("attr: quão atraente p1 achou p2\n")
## attr: quão atraente p1 achou p2
cat("sinc: quão sincero p1 achou p2\n")
## sinc: quão sincero p1 achou p2
cat("intel: quão inteligente p1 achou p2\n")
## intel: quão inteligente p1 achou p2
cat("fun: quão divertido p1 achou p2\n")
## fun: quão divertido p1 achou p2
cat("amb: quão ambicioso p1 achou p2\n")
## amb: quão ambicioso p1 achou p2
cat("shar: quanto p1 achou que compartilha interesses e hobbies com p2\n")
## shar: quanto p1 achou que compartilha interesses e hobbies com p2
cat("like: no geral, quanto p1 gostou de p2?\n")
## like: no geral, quanto p1 gostou de p2?
cat("prob: que probabiliade p1 acha que p2 tem de querer se encontrar novamente com p- (escala 1-10)\n")
## prob: que probabiliade p1 acha que p2 tem de querer se encontrar novamente com p- (escala 1-10)
cat("attr3_s: quanto p1 acha que é atraente\n")
## attr3_s: quanto p1 acha que é atraente
cat("sinc3_s: quanto p1 acha que é sincero\n")
## sinc3_s: quanto p1 acha que é sincero
cat("intel3_s: quanto p1 acha que é inteligente\n")
## intel3_s: quanto p1 acha que é inteligente
cat("fun3_s: quanto p1 acha que é divertido\n")
## fun3_s: quanto p1 acha que é divertido
cat("amb3_s: quanto p1 acha que é ambicioso\n")
## amb3_s: quanto p1 acha que é ambicioso
cat("dec: se houve match entre p1 e p2 - sim ou não.\n")
## dec: se houve match entre p1 e p2 - sim ou não.

Na descrição das variáveis gostaríamos de enfatizar a variável “dec” por ser a variável resposta, representando a decisão tomada por um indivíduo após um encontro de speed dating e a variável “gender” que representa o gênero do indivíduo, ela é do tipo categórica, pode assumir dois valores: “1” para masculino e “0” para feminino.

Fit Relacionando Preferências e Gêneros em Speed Dating

Podemos inicialmente a partir do código do Prof. Nazareno, realizar uma EDA, uma análise de regressão logística, avaliar o modelo ajustado, criar visualizações gráficas e gerar uma tabela de contingência para comparar as previsões com os valores reais em relação ao gênero, da seguinte forma:

s_dating <- read_csv("5-regressao/speed-dating/speed-dating2.csv") %>% 
  mutate(dec = as.factor(dec), 
         gender = as.factor(gender))
## Rows: 4918 Columns: 44
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (4): field, from, career, dec
## dbl (40): iid, gender, order, pid, int_corr, samerace, age_o, age, race, spo...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
gendermodel <- glm(dec ~ gender, 
                  data = s_dating, 
                  family = "binomial")

tidy(gendermodel, conf.int = TRUE, exponentiate = TRUE)
## # A tibble: 2 × 7
##   term        estimate std.error statistic  p.value conf.low conf.high
##   <chr>          <dbl>     <dbl>     <dbl>    <dbl>    <dbl>     <dbl>
## 1 (Intercept)    0.572    0.0420    -13.3  2.00e-40    0.527     0.621
## 2 gender1        1.53     0.0582      7.36 1.87e-13    1.37      1.72
glance(gendermodel)
## # A tibble: 1 × 8
##   null.deviance df.null logLik   AIC   BIC deviance df.residual  nobs
##           <dbl>   <int>  <dbl> <dbl> <dbl>    <dbl>       <int> <int>
## 1         6678.    4917 -3312. 6627. 6640.    6623.        4916  4918
pR2(gendermodel)
## fitting null model for pseudo-r2
##           llh       llhNull            G2      McFadden          r2ML 
## -3.311624e+03 -3.338863e+03  5.447805e+01  8.158173e-03  1.101615e-02 
##          r2CU 
##  1.483102e-02
expectativa_realidade <- augment(gendermodel, 
                                type.predict = "response")

expectativa_realidade <- expectativa_realidade %>% 
  mutate(genderNum = ifelse(gender == "1", 1, 0)) 

ggplot(expectativa_realidade, aes(x = genderNum, y = ..count.., fill = factor(genderNum))) +
  geom_bar(alpha = 0.5, position = "dodge") +
  geom_text(aes(label = ..count..), stat = "count", position = position_dodge(width = 0.9), vjust = -0.5) +
  xlab("Gênero") +
  ylab("Contagem") +
  scale_fill_manual(values = c("#999999", "#E69F00"), labels = c("Feminino", "Masculino")) +
  theme_minimal()
## Warning: The dot-dot notation (`..count..`) was deprecated in ggplot2 3.4.0.
## ℹ Please use `after_stat(count)` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

expectativa_realidade <- expectativa_realidade %>% 
  mutate(categoria_prevista = ifelse(.fitted > 0.5, "1", "0"))

table(expectativa_realidade$categoria_prevista, expectativa_realidade$gender)
##    
##        0    1
##   0 2454 2464

Uma Análise Exploratória de Dados (EDA) para obter insights sobre os nossos dados.

Como anteriormente já disponiblizamos informações básicas sobre cada variável, agora, analisaremos algumas variáveis categóricas usando a função table() para verificar as frequências das categorias.

Depois vamos visualizr a distribuição da idade usando um histograma, também calcularemos a matriz de correlação entre as variáveis numéricas usando a função cor() e as exibiremomos.

No final, optamos por investigar a relação entre a variável “like” (quanto p1 gostou de p2) e a decisão de match. Plotaremos mais um histograma mostrando a distribuição de gostar de p2, com as barras coloridas de acordo com a decisão de match.

OBS: Como o código anterior não completa todas as lacunas, daí vimos a necessidade de acrescer esta EDA para facilitar o entendimento e compreensão dos resultados.

table(s_dating$gender)  # Frequência das categorias de sexo
## 
##    0    1 
## 2454 2464
table(s_dating$race)  # Frequência das categorias de raça
## 
##    1    2    3    4    6 
##  244 2843  399 1111  301
table(s_dating$samerace)  # Frequência das categorias de mesma raça
## 
##    0    1 
## 2920 1998
ggplot(s_dating, aes(x = age)) +
  geom_histogram(fill = "blue", color = "white", bins = 20) +
  xlab("Idade") +
  ylab("Frequência") +
  ggtitle("Distribuição de Idade")
## Warning: Removed 52 rows containing non-finite values (`stat_bin()`).

cor_matrix <- cor(s_dating[, c("int_corr", "attr", "sinc", "intel", "fun", "amb", "shar", "like")])
print(cor_matrix)
##          int_corr attr sinc intel fun amb shar like
## int_corr        1   NA   NA    NA  NA  NA   NA   NA
## attr           NA    1   NA    NA  NA  NA   NA   NA
## sinc           NA   NA    1    NA  NA  NA   NA   NA
## intel          NA   NA   NA     1  NA  NA   NA   NA
## fun            NA   NA   NA    NA   1  NA   NA   NA
## amb            NA   NA   NA    NA  NA   1   NA   NA
## shar           NA   NA   NA    NA  NA  NA    1   NA
## like           NA   NA   NA    NA  NA  NA   NA    1
ggplot(s_dating, aes(x = like, fill = dec)) +
  geom_histogram(position = "identity", alpha = 0.7, bins = 20) +
  xlab("Gostou de P2") +
  ylab("Contagem") +
  scale_fill_manual(values = c("blue", "red"), labels = c("Não Match", "Match")) +
  ggtitle("Distribuição de Gostar de P2 por Decisão de Match")
## Warning: Removed 122 rows containing non-finite values (`stat_bin()`).

Explicação do relatório:

O relatório de regressão logística busca entender como a variável “gender”(gênero-uma pessoa) está relacionada à decisão de ter um segundo encontro (“dec”-decisão se aceitar ou não).Nesse caso, o modelo tenta prever a probabilidade de um indivíduo decidir ter um segundo encontro com base no seu gênero.

Coeficientes: O relatório exibe os coeficientes estimados do modelo de regressão logística. Esses coeficientes representam o efeito do gênero na probabilidade de decidir ter um segundo encontro.

Intervalos de confiança: O relatório também apresenta intervalos de confiança para os coeficientes estimados. Esses intervalos fornecem uma faixa plausível de valores para os coeficientes, com um certo nível de confiança.

Medidas resumidas: O relatório inclui medidas resumidas do modelo de regressão logística, como deviance, AIC (critério de informação de Akaike) e outros. Essas medidas ajudam a avaliar o ajuste do modelo aos dados.

Pseudo R²: O relatório calcula o pseudo R² do modelo de regressão logística. O pseudo R² é uma medida de quão bem o modelo se ajusta aos dados. Ele fornece uma estimativa da proporção da variabilidade na variável resposta que é explicada pelas variáveis independentes.

No final o código também cria uma visualização gráfica usando um gráfico de barras empilhadas. Esse gráfico mostra a contagem das previsões do modelo de regressão logística em relação ao gênero. Ele permite comparar as frequências das previsões para cada categoria de gênero.

Criando o Modelo

Criar uma divisão treino e teste.

sf_dating <- read_csv("5-regressao/speed-dating/speed-dating2.csv")
## Rows: 4918 Columns: 44
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (4): field, from, career, dec
## dbl (40): iid, gender, order, pid, int_corr, samerace, age_o, age, race, spo...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
proporcao_teste <- 0.3
set.seed(123)
    
indices_teste <- createDataPartition(sf_dating$dec, times = 1, p = proporcao_teste, list = FALSE)
    
dados_treino <- sf_dating[-indices_teste, ]  # Subconjunto dos dados para treinamento
dados_teste <- sf_dating[indices_teste, ]   # Subconjunto dos dados para teste

Modelo (com no mínimo 4 variáveis) - Regressão logística com um conjunto de variáveis explicativas escolhidas.

Observando os resultados abaixo, podemos interpretar os efeitos das variáveis explicativas observando os coeficientes estimados e seus intervalos de confiança. Os valores de odds ratio maiores que 1 indicam um efeito positivo na chance de match, enquanto valores menores que 1 indicam um efeito negativo. A magnitude do efeito é indicada pelo valor do Odds Ratio. Quanto maior o valor, maior é a magnitude do efeito da variável explicativa nas chances de match.

variaveis_explicativas <- c("fun", "shar", "dec", "attr", "amb")
dados <- select(dados_treino, dec, gender, all_of(variaveis_explicativas)) %>%
  mutate(dec = as.factor(dec), gender = as.factor(gender))

modelo <- glm(dec ~ ., data = dados, family = "binomial")
resultado <- tidy(modelo, conf.int = TRUE, exponentiate = TRUE)

print(resultado)
## # A tibble: 6 × 7
##   term        estimate std.error statistic  p.value conf.low conf.high
##   <chr>          <dbl>     <dbl>     <dbl>    <dbl>    <dbl>     <dbl>
## 1 (Intercept)  0.00360    0.275     -20.4  9.71e-93  0.00208   0.00612
## 2 gender1      1.27       0.0922      2.62 8.88e- 3  1.06      1.52   
## 3 fun          1.25       0.0354      6.21 5.44e-10  1.16      1.34   
## 4 shar         1.36       0.0288     10.6  2.68e-26  1.28      1.44   
## 5 attr         1.78       0.0339     17.0  6.36e-65  1.67      1.90   
## 6 amb          0.801      0.0334     -6.63 3.25e-11  0.750     0.855
ggplot(resultado, aes(x = term, y = estimate)) +
  geom_point() +
  geom_errorbar(aes(ymin = conf.low, ymax = conf.high), width = 0.2) +
  coord_flip() +
  xlab("Variável") +
  ylab("Odds Ratio") +
  ggtitle("Magnitude dos Efeitos nas Chances de Match")

Mostrar o O valor de R² ajustado (pR2) do modelo é:

modelo <- glm(dec ~ ., data = dados, family = "binomial")
pr2 <- pR2(modelo)
## fitting null model for pseudo-r2
print(pr2)
##           llh       llhNull            G2      McFadden          r2ML 
## -1447.9080320 -1982.5605795  1069.3050948     0.2696778     0.3076831 
##          r2CU 
##     0.4134184

Calculando a acuráncia do modelo:

previsoes <- predict(modelo, newdata = dados, type = "response")

previsoes_binarias <- ifelse(previsoes > 0.5, 1, 0)
matriz_confusao <- table(dados$dec, previsoes_binarias)

acuracia <- sum(diag(matriz_confusao)) / sum(matriz_confusao)
print(acuracia)
## [1] 0.7489684

O valor abaixo descrito representa a precisão calculada como a razão entre os verdadeiros positivos e o total de previsões positivas.

verdadeiros_positivos <- matriz_confusao[2, 2]
falsos_positivos <- matriz_confusao[1, 2]
precisao <- verdadeiros_positivos / (verdadeiros_positivos + falsos_positivos)

print(precisao)
## [1] 0.7178602

O valor abaixo impresso representa o número total de classificações corretas, este valor é a soma dos valores de verdadeiros positivos (VP) e verdadeiros negativos (VN) extraídos da matriz de confusão.

VP <- matriz_confusao[2, 2]  # Verdadeiros positivos
VN <- matriz_confusao[1, 1]  # Verdadeiros negativos

classificacoes_corretas <- VP + VN

print(classificacoes_corretas)
## [1] 2178

O valor abaixo impresso representa o cálculo do recall do modelo (taxa de verdadeiros positivos), aqui temos o recall como a razão entre os verdadeiros positivos e o total de observações que realmente pertencem à classe positiva.

VP <- matriz_confusao[2, 2]  # Verdadeiros positivos
FN <- matriz_confusao[2, 1]  # Falsos negativos

recall <- VP / (VP + FN)
print(recall)
## [1] 0.6736842

O valor abaixo impresso representa o cálculo do F1-Score, aqui temos o recall como a razão entre os verdadeiros positivos e o total de observações que realmente pertencem à classe positiva.

VP <- matriz_confusao[2, 2]  # Verdadeiros positivos
FP <- matriz_confusao[1, 2]  # Falsos positivos
FN <- matriz_confusao[2, 1]  # Falsos negativos

precisao <- VP / (VP + FP)
recall <- VP / (VP + FN)

fscore <- 2 * (precisao * recall) / (precisao + recall)

print(fscore)
## [1] 0.695071

A AUC (Area Under the Curve), também conhecida como área sob a curva ROC (Receiver Operating Characteristic), é uma representação gráfica da taxa de verdadeiros positivos em relação à taxa de falsos positivos para diferentes valores de limiar de classificação e o valor determinado para este modelo está abaixo.

auc <- roc(dados$dec, previsoes)$auc
## Setting levels: control = no, case = yes
## Setting direction: controls < cases
print(auc)
## Area under the curve: 0.8316

Conclusão

O valor de R² ajustado (pR2) do modelo é 0.269 (McFadden), que representa a proporção da variabilidade explicada pelas variáveis explicativas incluídas no modelo de regressão logística. Então, podemos inferir que quanto mais próximo de 1 for o valor de pR2, melhor é o ajuste do modelo aos dados, mas também é dito por McFadden, D. (1973) (https://scholar.google.com/scholar?q=Conditional+logit+analysis+of+qualitative+choice+behavior+Daniel+McFadden) que em alguns casos os valores entre 0,2 e 0,4 podem ser considerados aceitáveis.

A acuráncia do modelo é representativa com 74.89%.

Como podemos notar o valor da AUC é igual a 83.16% e este aproxima-se bastante de 1, indicando um melhor desempenho do modelo em termos de separação entre as classes positiva e negativa.

Os fatores nos dados têm efeito positivos porque a taxa de verdadeiros positivos é maior, quanto a magnitude o modelo apresenta valores consideráveis nos cálculos das métricas tendo um resultado entre 70% a 83%.