O objetivo deste relatório é analisar através de regressão logística dados sobre matches entre casais participantes de encontros relâmpagos, ou seja, de curta duração. Após conversar por um tempo durante o encontro, cada par é submetido a um formulário para coletar informações pessoais, assim como sobre sua percepção do companheiro. Com base nos dados coletados por esse formulário, iremos buscar determinar se houve um match entre o casal, ou seja, se ambas as partes estão dispostas a se encontrar novamente.

speed_datin <- read_csv("speed-dating2.csv", col_types = cols_only(
  dec = col_character(),
  samerace = col_integer(),
  age_o = col_integer(),
  age = col_integer(),
  shar = col_double(),
  attr = col_double(),
  intel = col_double(),
  fun = col_double(),
  sinc = col_double(),
  int_corr = col_double(),
  amb = col_double()
))

speed_datin <- speed_datin %>%
  mutate(samerace = samerace == 1,
         agediff = abs(age_o - age),
         match = dec == "yes",
         dec = ifelse(dec == "yes", "Sim", "Não")) %>%
  select(-age, -age_o)

speed_datin <- speed_datin %>%
  filter(across(.fns = function(x) !is.na(x)))

Explorando os dados

No gráfico abaixo, temos a distribuição da quantidade de matches. É possível ver que temos uma maioria de encontros que não levou a match (57.36%), indicando assim que a chance base de não haver match deve ser maior que a de haver.

speed_datin %>%
  ggplot(aes(x = dec)) +
  geom_bar(position = "dodge", fill = 'coral', color = 'black') +
  labs(
    y = "Contagem",
    x = "Houve match?",
    title = "Distribuição dos matches"
  )

Dentre as possíveis variáveis presentes nos dados, escolhemos quatro para compor o conjunto das variáveis independentes. Essas variáveis foram escolhidas por representarem a percepção de uma parte sobre a outra, são elas:

Todas estas variáveis variam em uma escala de 0 a 10, correspondendo ao intervalo [0%, 100%]. Vejamos então a distribuição destas variáveis agrupadas pela existência de match, no gráfico a seguir. É possível ver que em todos os casos a mediana do grupo em que houve match é superior às demais, entretanto em quase todos os casos a distribuição se estende ao longo de quase toda a escala independente da existência de match. Essa extensão pode ser composta predominantemente por pontos extremos como no caso da variável sinc ou do próprio dado, como no caso de shar.

speed_datin %>%
  pivot_longer(cols = c("attr", "shar", "fun", "sinc"), names_to = "variable", values_to = "values") %>%
  ggplot(aes(x = dec, y = values)) +
  geom_boxplot() +
  labs(
    y = "Valor da variável",
    x = "Houve match?",
    title = "Distribuição das variáveis independentes"
  ) +
  facet_wrap(~ variable)

Gerando o modelo

bm <- glm(match ~ attr + fun + sinc + shar, 
          data = speed_datin, 
          family = "binomial")

coefs <- tidy(bm, conf.int = TRUE, exponentiate = TRUE) %>% select(-p.value)
coefs
## # A tibble: 5 × 6
##   term        estimate std.error statistic conf.low conf.high
##   <chr>          <dbl>     <dbl>     <dbl>    <dbl>     <dbl>
## 1 (Intercept)  0.00408    0.227     -24.2   0.00260   0.00632
## 2 attr         1.74       0.0285     19.4   1.65      1.84   
## 3 fun          1.23       0.0294      6.92  1.16      1.30   
## 4 sinc         0.853      0.0276     -5.77  0.808     0.900  
## 5 shar         1.33       0.0236     12.1   1.27      1.39
pR2(bm)
## fitting null model for pseudo-r2
##           llh       llhNull            G2      McFadden          r2ML 
## -2045.0283256 -2741.2944494  1392.5322477     0.2539917     0.2928931 
##          r2CU 
##     0.3934127

O modelo para a chance de haver match é da forma:

\[ match = 0.004 \cdot 1.74^{attr} \cdot 1.23^{fun} \cdot 0.85^{sinc} \cdot 1.33^{shar} \]

Assim é possível ver que, mantendo-se constantes os demais:

Além disso, vale ressaltar que o aumento de sinceridade reduzir as chances é o mais estranho dentre os termos, entretanto sua distribuição (vista anteriormente) mostrava vários pontos extremos tendendo a valores baixos de sinceridade no caso match, isto deve explicar tal comportamento.

Este modelo foi capaz de explicar aproximadamente ¼ da variabilidade (McFadden = 0.254) da variável de resposta, ou seja, da ocorrência de match, sendo um valor significativo uma vez que foram consideradas apenas variáveis que dizem respeito a percepções de uma pessoa sobre outra.

Para finalizar, realizamos inferências sobre os coeficientes do modelo, para entender como eles se comportam na população. A seguir temos os gráficos com os intervalos de confiança de 95% de confiança para eles:

coefs %>%
  filter(term != "(Intercept)") %>%
  ggplot(aes(y = reorder(term, estimate), x = estimate, 
             xmin = conf.low, xmax = conf.high,
             label = paste("[", round(conf.low,2), ";", round(conf.high,2), "]"))) +
  geom_point(color = 'coral') +
  geom_linerange() +
  geom_text(nudge_y = -.12, nudge_x = .025, size = 3) +
  geom_vline(xintercept = 1, color = 'red', linetype = 'dashed') +
  labs(
    y = "Variável",
    x = "Valor do coeficiente",
    title = "Intervalos de confiança para os coeficientes"
  )

O gráfico nos confirma que o termo mais influente é de fato o de atração, podendo levar a um aumento entre 65% e 84%. Além disso, vemos ainda que o fator sinceridade, tem um efeito negativo com seus coeficientes sendo menor que 1, mesmo quando em intervalo de confiança, porém esse efeito não é tão forte uma vez que os valores estão próximos a 1. Para os demais termos temos intervalos com sobreposição e portanto não é possível definir ordem entre seus efeitos, podendo apenas afirmar que o efeito existe e é positivo.