EDA

dates <- dados %>% 
  mutate(dec = as.factor(dec),
         gender = as.factor(gender),
         age_gap = abs(age - age_o))

Por curiosidade, vejamos qual a distribuição da diferença de idade entre os casais.

p <- dates %>% 
  ggplot( aes(x=age_gap)) +
  geom_histogram( binwidth=3, fill="#69b3a2", color="#e9ecef", alpha=0.9) +
  ggtitle("Diferença de idade") +
  hrbrthemes::theme_ipsum() +
  theme(
    plot.title = element_text(size=15)
  )
p

Embora a maior parte dos casais tenha uma diferença de idade abaixo de 5 anos, existe um volume considerável de casais entre 5 e 10 anos de diferença de idade. Iremos guardar essa informação como age_gap, a diferença em anos de idade dos casais.

Para nossa análise iremos utilizar as variáveis que indicam avaliações feitas de uma pessoa sobre outra que conheceu (attr, sinc, intel, fun, shar e like), além da correlação entre os interesses (int_corr), se ambos possuem a mesma raça (samerace) e a diferença de idade (age_gap). Nossa variável resposta é a dec, que indica se houve match ou não.

Vejamos como essas variáveis se relacionam:

dates_bin <- dates %>% 
    mutate(dec = ifelse(str_detect(tolower(dec), "yes"), 1, 0))
corr <- cor(dates_bin %>% select(int_corr, 
                                 samerace, 
                                 age_gap,
                                 attr,
                                 sinc,
                                 intel,
                                 fun,
                                 shar,
                                 like, 
                                 dec), use = "pairwise.complete.obs")
ggcorr(corr,
    palette = "RdYlBu",
    nbreaks = 10,
    label = TRUE,
    label_round = 2,
    label_size = 3,
    hjust = 0.75,
    size = 4,
    color = "black",
    angle = -15) +
  hrbrthemes::theme_ipsum_rc()

Podemos perceber que, além da variável like, que indica que uma pessoa gostou da outra, a variável attr parece ter uma correlação positiva razoávelmente alta com dec, indicando que o match tem relação com o fato de uma pessoa achar outra atraente ou não.

Alguns fatos interessantes:

• Correlação negativa razoável entre age_gap e fun, que pode nos dizer que as pessoas não se acham divertidas quando a diferença de idade é alta.
• Correlação negativa razoável entre age_gap e like, pessoas parecem não gostar daquelas com diferença alta de idade.
• Correlação positiva alta entre as variáveis (attr e fun) e like, aparentemente pessoas gostam daquelas que lhe aparentam mais atraentes e divertidas.

Modelo

Nós utilizaremos um modelo de regressão logística para prever se o casal deu match ou não, mas para isso precisamos checar o balanceamento das classes para que não interfiram em nosso modelo.

p <- dates %>% 
  ggplot( aes(x=dec)) +
  geom_bar( fill="#69b3a2", color="#e9ecef", alpha=0.9) +
  ggtitle("Match?") +
  hrbrthemes::theme_ipsum() +
  theme(
    plot.title = element_text(size=15)
  )
p

Embora pouca, existe sim uma diferença entre as classes da variável resposta, portanto, faremos um downsample para balancear as classes.

balanced <- dates %>% downSample(dates$dec)

p <- balanced %>% 
  ggplot( aes(x=dec)) +
  geom_bar( fill="#69b3a2", color="#e9ecef", alpha=0.9) +
  ggtitle("Match?") +
  hrbrthemes::theme_ipsum() +
  theme(
    plot.title = element_text(size=15)
  )
p

Agora com as classes balanceadas, vejamos o modelo.

modelo = glm(formula = dec ~ int_corr + samerace + age_gap + attr + sinc + intel + fun + shar + like,
             data = balanced,
             family = "binomial")
             
t_modelo <- tidy(modelo,
                 conf.int = TRUE,
                 exponentiate = TRUE)

kable(t_modelo, format = 'html') %>%
  kable_styling(bootstrap_options = c('hover', 'striped'))

As variáveis attr e like são as mais significativas, com valores estimados de 1.914 (IC [1.751, 2.097] com 95% de confiança) e 1.512 (IC [1.418, 1.614] com 95% de confiança) respectivamente. As outras apresentam estimativas mais modestas, embora todas elas possuam influência razoável no provável match.

Como utilizamos um modelo de regressão logística, não temos um R², mas podemos utilizar um pseudo R²:

pR2(modelo)

## fitting null model for pseudo-r2

##           llh       llhNull            G2      McFadden          r2ML 
## -1645.7538368 -2378.4717643  1465.4358550     0.3080625     0.3474499 
##          r2CU 
##     0.4633658

Avaliando o modelo com o R² de McFadden vemos que o modelo explica 30% dos nossos dados.

Concluímos que, com os dados disponíveis e o nosso modelo, quanto mais uma pessoa acha outra atraente e gostar dela, maiores as chances do match acontecer.