Speed Dating

library(broom)
library(dplyr)
library(DT)
library(ggplot2)
library(ggbeeswarm)
library(gridExtra)
library(here)
library(hrbrthemes)
library(pscl)
library(readr)
library(scales)

theme_set(theme_ipsum_tw())
set.seed(123)

dados <- read_csv(here('data/speed-dating.csv'))
dados <- dados %>%
  inner_join(dados, by = c("iid" = "pid", "pid" = "iid", "order")) %>%
  mutate(interests_corr = int_corr.x * 100,
         age_difference = abs(age.x - age.y),
         appearance = attr.x + attr.y,
         funny = fun.x + fun.y,
         match = dec.x) %>%
  select(interests_corr, age_difference, appearance, funny, match) %>%
  na.omit() %>%
  mutate(match = if_else(match == 'yes', 'Sim', 'Não'),
         match_f = if_else(match == 'Sim', 1, 0))

theme_settings <- theme(plot.title = element_text(family = 'Times New Roman', face = 'bold',
                                                 vjust = 1.5, hjust = 0.5, size = 16),
                        axis.title.x = element_text(family = 'Times New Roman', face = 'bold',
                                                    vjust = -2, hjust = 0.5, size = 13),
                        axis.title.y = element_text(family = 'Times New Roman', face = 'bold',
                                                    vjust = 3, hjust = 0.5, size = 13),
                        axis.text.x = element_text(family = 'Times New Roman', size = 12),
                        axis.text.y = element_text(family = 'Times New Roman', size = 12),
                        strip.text = element_text(family = 'Times New Roman', face = 'bold',
                                                  vjust = 2, hjust = 0.5, size = 13))

Sobre a análise

Essa análise foi produzida como exercício da disciplina de Fundamentos de Pesquisa em Ciência da Computação (FPCC2) do Programa de Pós-Graduação em Ciência da Computação (PPGCC) da Universidade Federal de Campina Grande (UFCG). O conjunto de dados utilizado se baseia nos resultados de um experimento, realizado por professores Columbia Business School, envolvendo encontros relâmpago (speed dating) de 4 minutos entre 310 jovens americanos. Para mais detalhes, acesse esse repositório.

As variáveis independentes

O principal objetivo desse exercício é a criação de um modelo de regressão logística que visa explicar se os casais irão (ou não) ter novos encontros, o famoso “deu match?”. Esse modelo deve ser treinado a partir do conjunto de dados disponibilizado e se basear em apenas 4 variáveis independentes. Durante a seleção dessas variáveis, busquei escolher aquelas que envolvessem ambos os membros do casal e fossem (relativamente) perceptíveis em apenas 4 minutos de encontro. Após algumas manipulações nos dados, selecionei as seguintes variáveis:

Correlação de Interesses: Correlação entre os interesses dos membros do casal. Para facilitar a explicação, os valores foram multiplicados por 100 e, portanto, variam na escala de -100 a 100.
Diferença de Idade: Valor absoluto da diferença de idade entre os membros do casal.
Aparência: Soma das notas que os membros do casal atribuíram um ao outro no quesito “o quão atraente o seu par é?”, variando na escala de 0 a 20.
Diversão: Soma das notas que os membros do casal atribuíram um ao outro no quesito “o quão divertido o seu par é?”, variando na escala de 0 a 20.

Abaixo estão apresentadas as distribuições dessas variáveis em relação à ocorrência (ou não) dos matches entre os casais.

plot1 <- dados %>%
  ggplot(aes(x = factor(match, levels = c('Sim', 'Não')),
             y = interests_corr, color = match)) +
  geom_quasirandom(size = 1.5, alpha = 0.05, show.legend = FALSE) +
  scale_color_manual(values = c('#ff5d8f', '#a7c957')) +
  labs(x = 'Deu Match?',
       y = 'Correlação de Interesses') +
  theme_settings

plot2 <-dados %>%
  ggplot(aes(x = factor(match, levels = c('Sim', 'Não')),
             y = age_difference, color = match)) +
  geom_quasirandom(size = 1.5, alpha = 0.05, show.legend = FALSE) +
  scale_color_manual(values = c('#ff5d8f', '#a7c957')) +
  labs(x = 'Deu Match?',
       y = 'Diferença de Idade') +
  theme_settings

plot3 <-dados %>%
  ggplot(aes(x = factor(match, levels = c('Sim', 'Não')),
             y = appearance, color = match)) +
  geom_quasirandom(size = 1.5, alpha = 0.05, show.legend = FALSE) +
  scale_color_manual(values = c('#ff5d8f', '#a7c957')) +
  labs(x = 'Deu Match?',
       y = 'Aparência') +
  theme_settings

plot4 <-dados %>%
  ggplot(aes(x = factor(match, levels = c('Sim', 'Não')),
             y = funny, color = match)) +
  geom_quasirandom(size = 1.5, alpha = 0.05, show.legend = FALSE) +
  scale_color_manual(values = c('#ff5d8f', '#a7c957')) +
  labs(x = 'Deu Match?',
       y = 'Diversão') +
  theme_settings

media_aparencia_sim <- dados %>% filter(match == 'Sim') %>% pull(appearance) %>% mean() %>% round(2)
media_aparencia_nao <- dados %>% filter(match == 'Não') %>% pull(appearance) %>% mean() %>% round(2)
media_diversao_sim <- dados %>% filter(match == 'Sim') %>% pull(funny) %>% mean() %>% round(2)
media_diversao_nao <- dados %>% filter(match == 'Não') %>% pull(funny) %>% mean() %>% round(2)

grid.arrange(plot1, plot2, plot3, plot4, ncol = 2)

A correlação de interesses entre os casais apresenta valores entre -73 e 90. Além de uma forte concentração na faixa de valores de 0 a 50, essa distribuição também possui uma cauda negativa. Já a diferença de idade se distribui de 0 a 17 anos, com forte concentração em valores próximos a zero e cauda positiva. Vale notar que, para essas duas variáveis, a separação dos valores de acordo com a ocorrência (ou ausência) de match não causou diferenças perceptíveis nas distribuições.

Em contrapartida, ao observar as variáveis de aparência e de diversão, é evidente que os valores mais altos são mais comuns entre os casais que deram match. Os valores da variável de aparência se distribuem de 2 a 20 pontos e os valores da variáveis de diversão se distribuem de 1 a 20 pontos. Em ambos os casos, as distribuições são aproximadamente simétricas, mas os valores dos casais em não deram match geram discretas caudas negativas. Para os casais que deram match, as variáveis de aparência e de diversão apresentam médias de 13.19 e 13.76, respectivamente. Já para os casais que não deram match, esses valores são de 11.37 e 11.79.

O modelo

A seguir, executei a regressão logística a partir das variáveis independentes descritas anteriormente — correlação de interesses (\(X_1\)), diferença de idades (\(X_2\)), aparência (\(X_3\)) e diversão (\(X_4\)). Os resultados obtidos estão apresentados abaixo.

model <- glm(match_f ~ interests_corr + age_difference + appearance + funny, 
             data = dados, 
             family = 'binomial')

tidy(model, conf.int = TRUE, exponentiate = TRUE) %>%
  mutate(term = case_when(
    term == '(Intercept)' ~ 'Coef. Linear',
    term == 'interests_corr' ~ 'Corr. de Interesses',
    term == 'age_difference' ~ 'Diferença de Idade',
    term == 'appearance' ~ 'Aparência',
    term == 'funny' ~ 'Diversão',
    TRUE ~ ''
  )) %>%
  rename(Termo = term, Estimativa = estimate, `Limite Inferior (IC)` = conf.low,
         `Limite Superior (IC)` = conf.high) %>%
  select(Termo, Estimativa, `Limite Inferior (IC)`, `Limite Superior (IC)`) %>%
  mutate_at(2:4, funs(round(., 4))) %>%
  datatable()

pseudo_r2 <- pR2(model) %>%
  tidy() %>%
  filter(names == 'McFadden') %>%
  pull(x) %>%
  first() %>%
  round(4)

Alcançando Pseudo R² de McFadden de 0.106, o modelo produzido explica apenas 10.6% da variância da variável resposta e possui o seguinte formato:

\[p(match) = 0.0115 * 1.001^{X_1} * 0.984^{X_2} * 1.196^{X_3} * 1.171^{X_4}\]

Sobre a relação das variáveis independentes com o odds do match entre os casais:

O aumento de 1 unidade na correlação de interesses entre um casal aumenta o odds de ocorrência do match em 1.001 vezes (IC 95% [0.999; 1.004]) e, adotando o nível de confiança de 95% na estimativa para a população, essa alteração estará entre 0.999 e 1.004 vezes. Isso significa dizer que não é possível afirmar se essa variável produz um impacto positivo ou negativo, mas também que esse impacto será suficientemente pequeno para ser irrelevante.
O aumento de 1 ano na diferença de idade entre os membros de um casal diminui o odds de ocorrência do match em 0.984 vezes (IC 95% [0.958; 1.011]) e, adotando o nível de confiança de 95% na estimativa para a população, essa alteração estará entre 0.958 e 1.011 vezes. Assim, essa variável pode gerar um alteração positiva e irrelavante no odds ou, por outro lado, pode gerar uma alteração negativa e pequena (ou média, se ocorrer uma grande diferença de idade).
O aumento de 1 ponto nas notas de aparência entre os membros de um casal aumenta o odds de ocorrência do match em 1.196 vezes (IC 95% [1.155; 1.238]) e, adotando o nível de confiança de 95% na estimativa para a população, essa alteração estará entre 1.155 e 1.238 vezes. Isso significa dizer que a variável de aparência tem um efeito positivo sobre o odds do match entre o casal e que esse efeito pode ir pequeno a médio, uma vez que essa variável está na escala de 0 a 20.
O aumento de 1 ponto nas notas de diversão entre os membros de um casal aumenta o odds de ocorrência do match em 1.171 vezes (IC 95% [1.134; 1.203]) e, adotando o nível de confiança de 95% na estimativa para a população, essa alteração estará entre 1.134 e 1.203 vezes. Isso significa dizer que a variável de diversão tem um efeito positivo sobre o odds do match entre o casal e que esse efeito pode ir pequeno a médio, uma vez que essa variável também está na escala de 0 a 20.

Speed Dating

Matheus Alves dos Santos

Sobre a análise

As variáveis independentes

O modelo