Regressão Romântica

L4P3

Que fatores afetam as chances de um casal ter match?

Temos dados descrevendo 5000 encontros relâmpagos (speed dating, procura no google) de 4 minutos envolvendo 310 jovens americanos.

Aqui, queremos identificar quais fatores afetam na possibilidade e acontecer um segundo encontro, ou seja, fatores que influenciam na existência da “química” no encontro.

## Importando CSV e removendo NA's
speed_dating <- read_csv('../speed-dating2.csv', col_types = "")


head(speed_dating)

## # A tibble: 6 x 44
##     iid gender order   pid int_corr samerace age_o   age field  race from 
##   <dbl>  <dbl> <dbl> <dbl>    <dbl>    <dbl> <dbl> <dbl> <chr> <dbl> <chr>
## 1     1      0     4    11     0.14        0    27    21 Law       4 Chic~
## 2     1      0     3    12     0.54        0    22    21 Law       4 Chic~
## 3     1      0    10    13     0.16        1    22    21 Law       4 Chic~
## 4     1      0     5    14     0.61        0    23    21 Law       4 Chic~
## 5     1      0     7    15     0.21        0    24    21 Law       4 Chic~
## 6     1      0     6    16     0.25        0    25    21 Law       4 Chic~
## # ... with 33 more variables: career <chr>, sports <dbl>, tvsports <dbl>,
## #   exercise <dbl>, dining <dbl>, museums <dbl>, art <dbl>, hiking <dbl>,
## #   gaming <dbl>, clubbing <dbl>, reading <dbl>, tv <dbl>, theater <dbl>,
## #   movies <dbl>, concerts <dbl>, music <dbl>, shopping <dbl>, yoga <dbl>,
## #   attr <dbl>, sinc <dbl>, intel <dbl>, fun <dbl>, amb <dbl>, shar <dbl>,
## #   like <dbl>, prob <dbl>, match_es <dbl>, attr3_s <lgl>, sinc3_s <lgl>,
## #   intel3_s <lgl>, fun3_s <lgl>, amb3_s <lgl>, dec <chr>

Primeiramente, devemos dedicar um tempo para entender a natureza dos dados que temos a disposição. Entre as colunas que o dataset tem, vamos destacar algumas para exploração:

age_o : idade de p2
age : idade de p1
int_corr : correlação entre os interesses de p1 e p2
like : no geral, quanto p1 gostou de p2
attr : quão atraente p1 achou p2
fun : quão divertido p1 achou p2

Partimos da hipótese de que a diferença de idade pode ser um fator relevante para o match, e a correlação de interesses vai definir ainda mais a possibilidade de um segundo encontro. E claro, se a pessoa for atraente e divertida, é provável que exista um maior interesse. Sendo assim, vamos focar nessas variáveis e checar se as nossas hipóteses podem ajudar a formar um modelo interessante. Para isso, precisamos filtrar essas variáveis e checar a sua correlação.

Sabendo que a coluna dec diz se ouve ou não um segundo encontro entre o participante 1 e o participante 2, precisamos ajusta-la para valores numéricos para construir nosso modelo mais a frente.

speed_dating <- speed_dating %>%
    select(dec, age, age_o, int_corr, fun, attr, prob) %>% mutate(
         dec = case_when( .$dec == "no" ~ 0,
                          .$dec == "yes" ~ 1))

Correlação

ggpairs(speed_dating  %>%
    select(age, age_o, int_corr, fun, attr))

Não existe correlação forte entre as variáveis que foram selecionadas.

Explorndo um pouco mais

Mas, será que a correlação de interesses é, de fato, algo que pesa no encontro?

ggplot(data=speed_dating, aes(x = int_corr, y = prob)) +
  geom_bar(stat="identity", fill="slategray") +
  labs(x= "Correlação de Interesses",
       y = "Probabilidade de Novo Encontro (%)")

E a diferença de idade entre p1 e p2?

speed_dating <- speed_dating %>% mutate(diff_age = age - age_o)

ggplot(data=speed_dating, aes(x = diff_age, y = prob/25)) +
  geom_bar(stat="identity", fill="steelblue") +
  labs(x= "Diferença de idade",
       y = "Probabilidade de Novo Encontro (%)")

Para o caso da atração e da percepção de o quanto a pessoa é divertida.

ggplot(data=speed_dating, aes(x = attr, y = fun)) +
  geom_bar(stat="identity", fill="springgreen3") +
  labs(x= "Índice de Atração",
       y = "Percepção de Diversão")

Agora, partiremos para o modelo.

O modelo

Utilizaremos uma regressão logística com o modelo baseado nas nossas explorações dos dados.

model <- glm(dec ~ fun + attr + diff_age + int_corr, data = speed_dating, family = "binomial")

tidy(model, conf.int = TRUE, conf.level = 0.95, exp = T)

## # A tibble: 5 x 7
##   term        estimate std.error statistic   p.value conf.low conf.high
##   <chr>          <dbl>     <dbl>     <dbl>     <dbl>    <dbl>     <dbl>
## 1 (Intercept)  0.00328   0.192    -29.8    2.62e-195  0.00224   0.00475
## 2 fun          1.34      0.0231    12.8    2.83e- 37  1.28      1.40   
## 3 attr         1.75      0.0255    21.9    7.70e-106  1.66      1.84   
## 4 diff_age     0.999     0.00808   -0.0771 9.39e-  1  0.984     1.02   
## 5 int_corr     1.15      0.114      1.22   2.22e-  1  0.920     1.44

Analisando o resultado e as nossas hipóteses no início desta exploração, percebemos que estávamos errados em certos aspéctos. Por exemplo, nos resultados da correlação de interesses é possível ver que essa variável ficou em um IC de [0.91, 1.43], um valor baio para aquele que imaginávamos que seria uma dos principais fatores. Já =a variável attr teve um resultado em um IC de [1.66, 1.83] e fun ficou com IC de [1.07, 1.20], sendo menos relevante que ser atraente. O fator menos relevante foi a diferença de idade, apresentando um resultado de 1.14.

Respostas