L4P2: Regressão romântica

Nesta análise serão utilizados dados referentes aos encontros relâmpagos, conhecidos como “speed dating” nos EUA, envolvendo 310 jovens americanos. Os dados foram coletados por professores da Columbia Business School e mais detalhes do experimento pode ser acessado no link a seguir: https://faculty.chicagobooth.edu/emir.kamenica/documents/genderDifferences.pdf

Dados

Os dados contam com 4918 observações e 44 variáveis, como pode ser observado logo abaixo:

dados = read_csv(here::here("data/speed-dating2.csv"), cols(
  .default = col_double(),
  iid = col_character(),
  field = col_character(),
  from = col_character(),
  career = col_character(),
  attr3_s = col_logical(),
  sinc3_s = col_logical(),
  intel3_s = col_logical(),
  fun3_s = col_logical(),
  amb3_s = col_logical(),
  dec = col_character()
), col_names = TRUE) %>%
    mutate(dec = as.factor(dec), 
           gender = as.factor(gender))


glimpse(dados)

## Observations: 4,918
## Variables: 44
## $ iid      <chr> "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", "2"...
## $ gender   <fct> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,...
## $ order    <dbl> 4, 3, 10, 5, 7, 6, 1, 2, 8, 9, 10, 9, 6, 1, 3, 2, 7, ...
## $ pid      <dbl> 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 11, 12, 13, 1...
## $ int_corr <dbl> 0.14, 0.54, 0.16, 0.61, 0.21, 0.25, 0.34, 0.50, 0.28,...
## $ samerace <dbl> 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 1, 1,...
## $ age_o    <dbl> 27, 22, 22, 23, 24, 25, 30, 27, 28, 24, 27, 22, 22, 2...
## $ age      <dbl> 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 24, 24, 24, 2...
## $ field    <chr> "Law", "Law", "Law", "Law", "Law", "Law", "Law", "Law...
## $ race     <dbl> 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 2, 2, 2, 2, 2, 2, 2, 2,...
## $ from     <chr> "Chicago", "Chicago", "Chicago", "Chicago", "Chicago"...
## $ career   <chr> "lawyer", "lawyer", "lawyer", "lawyer", "lawyer", "la...
## $ sports   <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 3,...
## $ tvsports <dbl> 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,...
## $ exercise <dbl> 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7, 7, 7, 7, 7, 7, 7,...
## $ dining   <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10,...
## $ museums  <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 8, 8, 8, 8, 8, 8, 8, 8,...
## $ art      <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 6, 6, 6, 6, 6, 6, 6, 6,...
## $ hiking   <dbl> 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 3, 3, 3, 3, 3, 3, 3, 3,...
## $ gaming   <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 5, 5, 5, 5, 5, 5, 5, 5,...
## $ clubbing <dbl> 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 8, 8,...
## $ reading  <dbl> 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 10, 10, 10, 10, 10, 10,...
## $ tv       <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 1, 1, 1, 1, 1, 1, 1, 1,...
## $ theater  <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 9, 9, 9, 9, 9, 9, 9, 9,...
## $ movies   <dbl> 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 8, 8, 8, 8, 8...
## $ concerts <dbl> 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 7, 7, 7, 7, 7...
## $ music    <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 8, 8, 8, 8, 8, 8, 8, 8,...
## $ shopping <dbl> 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 3, 3, 3, 3, 3, 3, 3, 3,...
## $ yoga     <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
## $ attr     <dbl> 6, 7, 5, 7, 5, 4, 7, 4, 7, 5, 5, 8, 5, 7, 6, 8, 7, 5,...
## $ sinc     <dbl> 9, 8, 8, 6, 6, 9, 6, 9, 6, 6, 7, 5, 8, 9, 8, 7, 5, 8,...
## $ intel    <dbl> 7, 7, 9, 8, 7, 7, 7, 7, 8, 6, 8, 6, 9, 7, 7, 8, 9, 7,...
## $ fun      <dbl> 7, 8, 8, 7, 7, 4, 4, 6, 9, 8, 4, 6, 6, 6, 9, 3, 6, 5,...
## $ amb      <dbl> 6, 5, 5, 6, 6, 6, 6, 5, 8, 10, 6, 9, 3, 5, 7, 6, 7, 9...
## $ shar     <dbl> 5, 6, 7, 8, 6, 4, 7, 6, 8, 8, 3, 6, 4, 7, 8, 2, 9, 5,...
## $ like     <dbl> 7, 7, 7, 7, 6, 6, 6, 6, 7, 6, 6, 7, 6, 7, 8, 6, 8, 5,...
## $ prob     <dbl> 6, 5, NA, 6, 6, 5, 5, 7, 7, 6, 4, 3, 7, 8, 6, 5, 7, 6...
## $ match_es <dbl> 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3,...
## $ attr3_s  <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N...
## $ sinc3_s  <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N...
## $ intel3_s <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N...
## $ fun3_s   <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N...
## $ amb3_s   <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N...
## $ dec      <fct> yes, yes, yes, yes, yes, no, yes, no, yes, yes, no, n...

As colunas dos dados são descritas da seguinte maneira:

• iid : id do participante p1 no encontro
• gender : sexo do p1, 0 = mulher
• 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?
• 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 um match

Vamos nos conhecer?

Inicialmente vamos conhecer sobre o gênero dos participantes dos encontros relâmpagos:

dados %>%
  group_by(gender) %>%
  summarise(n = n()) %>%
  na.omit() %>%
  ggplot(aes(x = gender, y = n)) +
  geom_bar(stat = "identity", fill = "#E8D26E") +
  labs(x = "Gênero", y = "Quantidade de participantes") +
  scale_x_discrete(labels = c('Feminino', 'Masculino'))

Conhecendo agora um pouco sobre sua origem (raça):

dados %>%
  group_by(race) %>%
  summarise(n = n()) %>%
  na.omit() %>%
  ggplot(aes(x = as.factor(race), y = n)) +
  geom_bar(stat = "identity", fill = "#89ACD8") +
  labs(x = "Raça", y = "Quantidade de participantes") +
  scale_x_discrete(labels = c('1' = 'African American', '2' = 'Caucasian American','3' ='Hispanic American','4' = 'Asian American','5' ='Native American', '6' = 'Other'))

Após essa análise verificamos que a maioria dos participantes dos encontros são do sexo feminino e de origem caucasianas.

Avaliando os possíveis matchs

No formulário aplicado os participantes avaliam seus parceiros de encontro em diferentes categorias, medindo por exemplo se o parceiro foi “atrativo”, “inteligente”, “divertido” e “sincero” durante a experiência e se deseja sim/não realizar o “match”. As variáveis escolhidas foram as já mencionadas anteriormente, relembre sua breve descrição para iniciarmos os trabalhos:

- attr : quão atraente p1 achou p2
- intel : quão inteligente p1 achou p2
- fun : quão divertido p1 achou p2
- sinc : quão sincero p1 achou p2

dados.resume <- dados %>% 
  select(attr, intel, fun, sinc, dec) %>%
  na.omit() %>% 
  mutate(dec = as.factor(dec))

Dessa forma, utilizaremos o modelo de regressão logística para determinar o “odds” de uma pessoa dar match com um parceiro, tomando como base as variáveis escolhidas.

dados.model = glm(dec ~attr + intel + fun + sinc,
                        data = dados.resume ,
                        family = "binomial")

Com o modelo elaborado, podemos verificar quais dos atributos apresentam efeito para ocorrer o match e como é esse efeito.

tidy(dados.model, conf.int = TRUE, exponentiate = TRUE, conf.level = .95)

A regressão logística foi utilizada para verificar se os atributos escolhidos atraente (attr), inteligente (intel), divertido (fun) e sincero (sinc) possui associação na chance de match (dec) entre um casal de speed dating. A inteligência no encontro não obteve um efeito relevante, visto que o intervalo de confiança(IC) de 95% a inteligência está entre 0,8587 e 0,9927, considerado um efeito pequeno e negativo. O mesmo acontece com a sinceridade que apresentou IC de 95% entre 0,8732 e 0,9887, onde não teve um efeito expressivo e pode ser considerado como pequeno e negativo. Por outro lado, os atributos que se sobressaíram com efeito muito positivo e relevante foram o ser divertido, com valor estimado de 1,4096 e IC de 95% [1,3324, 1,4927], e ser atraente com valor estimado de 1,7889 e IC de 95% [1,6915, 1,8946]. Concluímos que para esse modelo ser uma pessoa atraente e divertida conta mais do que ser inteligente e sincera.

pR2(dados.model)

##           llh       llhNull            G2      McFadden          r2ML 
## -1930.4630631 -2520.3868024  1179.8474786     0.2340608     0.2738524 
##          r2CU 
##     0.3675013

Analisando o modelo considerando agora o R2 de McFadden verificamos que o modelo elaborado explica apenas 23% dos nossos dados. Ou seja, o nosso modelo pode servir como uma ilustração para os futuros encontros, mostrando aos interessados o foco no que realmente importa: ser atraente e divertido!