Speed Dating (encontro relâmpago)

Os dados

Temos dados descrevendo 5000 encontros relâmpagos (speed dating, procura no google) de 4 minutos envolvendo 310 jovens americanos. Os dados originais foram coletados por professores da Columbia Business School no experimento descrito aqui. Aqui estamos usando uma versão com menos colunas para agilizar para vocês.

Os participantes tinham vários encontros de 4 minutos por noite. Após cada um, preenchiam fichas avaliando aqueles com quem se encontraram. Cada linha nos dados representa um desses encontros.

As variáveis

iid : id do participante p1 no encontro
gender : sexo do p1, 0 = mulher, 1 = homem
order : dos vários encontros realizados em uma noite, esse foi o n-ésimo, segundo essa variável
pid : id do participante p2
int_corr : correlação entre os interesses de p1 e p2
samerace : p1 e p2 são da mesma raça? 1 = sim, 0 = não
age_o : idade de p2
age : idade de p1
field : campo de estudo de p1
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
from : de onde p1 é
career : que carreira p1 quer seguir
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.
attr : quão atraente p1 achou p2
sinc : quão sincero p1 achou p2
intel : quão inteligente p1 achou p2
fun : quão divertido p1 achou p2
amb : quão ambicioso p1 achou p2
shar : quanto p1 achou que compartilha interesses e hobbies com p2
like : no geral, quanto p1 gostou de p2?
prob : que probabiliade p1 acha que p2 tem de querer se encontrar novamente com p- (escala 1-10)
attr3_s : quanto p1 acha que é atraente
sinc3_s : quanto p1 acha que é sincero
intel3_s : quanto p1 acha que é inteligente
fun3_s : quanto p1 acha que é divertido
amb3_s : quanto p1 acha que é ambicioso
dec : se houve match entre p1 e p2 - sim ou não.

Pergunta

Que fatores nos dados têm efeito relevante na chance do casal ter um match? Descreva se os efeitos são positivos ou negativos e sua magnitude.

Exploração dos dados

dating_df %>%
    mutate(gender = case_when(.$gender == 0 ~ "feminino", .$gender == 1 ~ "masculino")) %>%
    ggplot(aes(x = gender, fill = gender)) +
    geom_bar() +
    ggtitle("Gráfico de barras com a qnt. de participantes por sexo") +
    xlab("Sexo") + ylab("Nº de participantes")

dating_df %>%
    ggplot(aes(x = age)) + 
    geom_histogram(binwidth = 1, fill = "skyblue", alpha = .75) +
    ggtitle("Histograma da idade do participante p1") +
    xlab("Idade") + ylab("Frequência")

dating_df %>%
    ggplot(aes(x = age_o)) + 
    geom_histogram(binwidth = 1, fill = "skyblue", alpha = .75) + 
    ggtitle("Histograma da idade do participante p2") +
    xlab("Idade") + ylab("Frequência")

A quantidade de participantes de ambos os sexos estão bem próximas, então não tem um viés para algum dos sexos. Já a idade dos participantes, seja p1 ou p2, está mais concentrada entre 20 a 30 anos.

Separando os dados

Abaixo, separamos os dados entre conjunto de treino (70% dos dados) e o conjunto de testes (30% dos dados).

sample <- sample(c(TRUE, FALSE), nrow(dating_df), replace=TRUE, prob=c(0.7,0.3))
dating_train  <- dating_df[sample, ]
dating_test   <- dating_df[!sample, ]

Modelo

bm <- glm(dec ~ fun + shar + like + attr + sinc, 
          data = dating_train, 
          family = "binomial")
stats <- tidy(bm, conf.int = TRUE, exponentiate = TRUE)
stats

## # 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.00242    0.286     -21.1  2.19e-98  0.00137   0.00419
## 2 fun          1.06       0.0375      1.58 1.13e- 1  0.986     1.14   
## 3 shar         1.19       0.0301      5.86 4.59e- 9  1.12      1.27   
## 4 like         1.87       0.0491     12.7  3.40e-37  1.70      2.06   
## 5 attr         1.50       0.0362     11.1  9.06e-29  1.39      1.61   
## 6 sinc         0.746      0.0353     -8.29 1.15e-16  0.696     0.799

#bm %>% augment(newdata = dating_test, type.predict = "response")

Após vários testes, o modelo que mais se destacou foi o match (dec) em relação às variáveis fun, shar, like, attr e sinc.

## [1] "Analisando os coeficientes estimados em relação ao odds, temos que: para cada unidade de like o odds (ou a chance) de match é aumentada em aproxidamente 86.90%, para cada unidade de attr o odds de match aumenta em 49.64%, para cada unidade de shar o odds aumenta 19.32% e para cada unidade de fun o odds aumenta 6.12%. Por outro lado, a variável sinc é a única que diminui o odds ao aumentar seu valor, a cada unidade de sinc o odds diminui em 25.38% aproximadamente. "

Análise do modelo

pR2(bm)

## fitting null model for pseudo-r2

##           llh       llhNull            G2      McFadden          r2ML 
## -1385.1485313 -1987.7997124  1205.3023623     0.3031750     0.3392209 
##          r2CU 
##     0.4553046

Analisando as métricas pseudo R2, especialmente McFadden (sugerida pelo prof. Nazareno), o modelo obteve aproximadamente 0,30. Segundo Hemmert et. al (https://journals.sagepub.com/doi/full/10.1177/0049124116638107), quando o valor da métrica de McFadden está entre 0.2 e 0.4 indica que o modelo é bom.

previsoes = bm %>% 
  augment(newdata = dating_test, type.predict = "response") %>% 
  mutate(segundo_modelo = .fitted > .5, 
         segundo_dados = dec == 1)

xtabs(~ segundo_modelo + segundo_dados, data = previsoes)

##               segundo_dados
## segundo_modelo FALSE TRUE
##          FALSE   608  159
##          TRUE    107  364

mosaic(segundo_dados ~ segundo_modelo, data = previsoes, shade = T)

Acurácia

Definição: Dentre todos as classificações, quantas o modelo classificou corretamente.

acuracia <- sum((predictions == dating_test$true_matches)) / NROW(predictions)
acuracia

## [1] 0.7851373

## [1] "A acurácia do modelo é de aproximadamente 78.51%."

Precisão

Definição: dentre todas as classificações de matches como sim que o modelo fez, quantas estão corretas

precisao <- sum(dating_test$true_matches) / (sum(dating_test$true_matches) + sum((predictions == T & dating_test$true_matches == F)))
precisao

## [1] 0.8301587

## [1] "A precisão do modelo é de aproximadamente 83.02%."

Recall

Definição: dentre todas as classificações de matches reais, quantas estão corretas.

recall <- sum(dating_test$true_matches) / (sum(dating_test$true_matches) + sum((predictions == F & dating_test$true_matches == T)))
recall

## [1] 0.7668622

## [1] "O recall do modelo é de aproximadamente 76.69%."

F1-Score

Definição: é a média harmônica entre precisão e recall.

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

## [1] 0.7972561

## [1] "O F1-score do modelo é de aproximadamente 79.73%."

Taxa de falsos positivos

Definição: dos matches classificados como sim pelo modelo, quantos não eram matches de fato.

falsos_positivos = sum((predictions == T & dating_test$true_matches == F)) / NROW(predictions)
falsos_positivos

## [1] 0.08642973

## [1] "A taxa de falsos positivos é de aproximadamente 8.64%."

Taxa de falsos negativos

Definição: dos matches classificados como não pelo modelo, quantos eram matches reais.

falsos_negativos = sum((predictions == F & dating_test$true_matches == T)) / NROW(predictions)
falsos_negativos

## [1] 0.128433

## [1] "A taxa de falsos negativos é de aproximadamente 12.84%."

Resumo

Examinando as métricas calculadas acima, o modelo apresenta acurácia, precisão, recall e F1-Score entre 75 a 80%, que são valores considerados bons para o modelo, indicando que o mesmo classifica bem. Além disso, a taxa de falsos positivos e a taxa de falsos negativos é baixa, variando entre 9 a 12%, indicando que o modelo não erra muito.

Lab 06 - Regressão Logística - Speed Dating

Felipe Emerson de O. Calixto

2023-06-26