Apresentação

Baseado no estudo “Gender Differences In Mate Selection: Evidence From A Speed Dating Experiment”, temos dados descrevendo 5000 encontros relâmpagos de 4 minutos envolvendo 310 jovens americanos. O Speed Dating consiste em um encontro rápido onde as mulheres ficam sentadas e os pretendentes “pulam” de mesa em mesa para ver, se no fim das contas, o casal tem um match considerando seus interesses e demais detalhes.

Tomando como base um conjunto de variáveis explicartivas, o objetivo deste relatório é responder: **“Que fatores nos dados têm efeito relevante na chance do casal ter um match?”.

dados = read_csv(here("speed-dating/speed-dating2.csv"),
                  col_types = cols(.default = col_double(), 
                                   field = col_character(),
                                   from = col_character(),
                                   career = col_character(),
                                   dec = col_character()
                                   )) %>% 
  mutate(dec = as.factor(dec), 
         gender = as.factor(gender))

Dados

Os participantes tinham vários encontros de 4 minutos por noite. Após cada um, preenchiam fichas avaliando aqueles com quem se encontraram. Cada linha nos dados representa um desses encontros.

As variáveis utilizadas são:

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

Análise Exploratória dos Dados

Visão geral dos dados utilizados

skimr::skim(dados)

Data summary
Name	dados
Number of rows	4918
Number of columns	44
_______________________
Column type frequency:
character	3
factor	2
numeric	39
________________________
Group variables	None

Variable type: character

skim_variable	n_missing	complete_rate	min	max	n_unique
field	20	1.00	3	51	148
from	36	0.99	2	58	172
career	46	0.99	2	77	218

Variable type: factor

skim_variable	n_missing	complete_rate	ordered	n_unique	top_counts
gender	0	1	FALSE	2	1: 2464, 0: 2454
dec	0	1	FALSE	2	no: 2873, yes: 2045

Variable type: numeric

skim_variable	n_missing	complete_rate	mean	sd	p0	p25	p50	p75	p100	hist
iid	0	1.00	274.67	183.91	1.00	88.00	273.00	431.00	552.0	▇▁▅▅▅
order	0	1.00	9.26	5.67	1.00	4.00	9.00	14.00	22.0	▇▆▅▃▂
pid	10	1.00	274.98	183.97	1.00	88.00	273.00	431.00	552.0	▇▁▅▅▅
int_corr	72	0.99	0.19	0.31	-0.73	-0.03	0.21	0.43	0.9	▁▅▇▇▂
samerace	0	1.00	0.41	0.49	0.00	0.00	0.00	1.00	1.0	▇▁▁▁▆
age_o	61	0.99	25.79	3.35	18.00	23.00	25.00	28.00	39.0	▃▇▆▁▁
age	52	0.99	25.78	3.35	18.00	23.00	25.00	28.00	39.0	▃▇▆▁▁
race	20	1.00	2.73	1.22	1.00	2.00	2.00	4.00	6.0	▇▁▃▁▁
sports	36	0.99	6.40	2.57	1.00	5.00	7.00	8.00	10.0	▂▅▆▇▆
tvsports	36	0.99	4.53	2.82	1.00	2.00	4.00	7.00	10.0	▇▆▅▅▃
exercise	36	0.99	6.12	2.33	1.00	5.00	6.00	8.00	10.0	▂▃▇▇▃
dining	36	0.99	7.69	1.79	1.00	7.00	8.00	9.00	10.0	▁▁▃▇▇
museums	36	0.99	6.88	2.08	0.00	6.00	7.00	8.00	10.0	▁▂▃▇▅
art	36	0.99	6.59	2.29	0.00	5.00	7.00	8.00	10.0	▁▃▅▇▅
hiking	36	0.99	5.77	2.56	0.00	4.00	6.00	8.00	10.0	▃▆▇▇▅
gaming	36	0.99	4.02	2.67	0.00	2.00	4.00	6.00	14.0	▇▇▅▁▁
clubbing	36	0.99	5.73	2.45	0.00	4.00	6.00	8.00	10.0	▃▅▆▇▃
reading	36	0.99	7.64	2.02	1.00	7.00	8.00	9.00	13.0	▁▂▇▇▁
tv	36	0.99	5.29	2.45	1.00	3.00	6.00	7.00	10.0	▅▅▇▇▂
theater	36	0.99	6.72	2.25	0.00	5.00	7.00	8.00	10.0	▁▃▅▇▆
movies	36	0.99	7.98	1.67	0.00	7.00	8.00	9.00	10.0	▁▁▂▇▇
concerts	36	0.99	6.82	2.10	0.00	6.00	7.00	8.00	10.0	▁▂▆▇▅
music	36	0.99	7.78	1.84	1.00	7.00	8.00	9.00	10.0	▁▁▃▇▇
shopping	36	0.99	5.48	2.57	1.00	3.00	6.00	7.00	10.0	▆▅▇▆▅
yoga	36	0.99	4.21	2.71	0.00	2.00	4.00	6.00	10.0	▇▅▅▃▂
attr	118	0.98	6.06	1.95	0.00	5.00	6.00	7.00	10.0	▁▃▇▇▂
sinc	161	0.97	7.05	1.81	0.00	6.00	7.00	8.00	10.0	▁▁▅▇▃
intel	166	0.97	7.27	1.59	0.00	6.00	7.00	8.00	10.0	▁▁▃▇▃
fun	197	0.96	6.29	1.98	0.00	5.00	6.00	8.00	10.0	▁▂▇▇▂
amb	421	0.91	6.70	1.83	0.00	6.00	7.00	8.00	10.0	▁▂▇▇▃
shar	643	0.87	5.32	2.16	0.00	4.00	5.00	7.00	10.0	▂▅▇▅▁
like	122	0.98	6.05	1.85	0.00	5.00	6.00	7.00	10.0	▁▂▇▇▂
prob	156	0.97	5.02	2.17	0.00	4.00	5.00	7.00	10.0	▃▅▇▅▁
match_es	460	0.91	3.17	2.36	0.00	2.00	3.00	4.00	10.0	▇▆▂▁▁
attr3_s	2874	0.42	7.08	1.55	3.00	7.00	7.00	8.00	10.0	▂▂▇▇▂
sinc3_s	2874	0.42	7.99	1.52	3.00	7.00	8.00	9.00	10.0	▁▁▃▆▇
intel3_s	2874	0.42	8.21	1.22	4.00	8.00	8.00	9.00	10.0	▁▁▂▇▇
fun3_s	2874	0.42	7.57	1.63	3.00	7.00	8.00	9.00	10.0	▁▂▇▇▇
amb3_s	2874	0.42	7.59	1.78	3.00	7.00	8.00	9.00	10.0	▂▂▅▃▇

Descritivo dos Dados

Antes de criarmos o modelo, vamos observar algumas informações relacionadas aos dados coletados do público que participa do Speed Dating - gênero, idade e raça.

# Gênero
 dados %>%
  group_by(gender) %>%
  summarise(n = n()) %>%
  ggplot(aes(x = gender, y = n)) +
  geom_bar(stat = "identity") + 
  labs(title = "Gênero dos Participantes do Speed Dating", x = "", y = "Número de participantes") +
  scale_x_discrete(labels = c('Feminino', 'Masculino'))

# Gênero e Idade
dados %>%
  group_by(gender, age) %>%
  summarise(n = n()) %>%
  na.omit() %>%
  ggplot(aes(x = age, y = n, fill = gender)) +
  geom_bar(stat = "identity") + 
  labs(title = "Idade e Gênero dos Participantes do Speed Dating", x = "Idade", y = "Número de participantes", fill = "Gênero") +
  scale_fill_discrete(labels = c("Feminino", "Masculino"))

## `summarise()` has grouped output by 'gender'. You can override using the
## `.groups` argument.

# Raça e Gênero
dados %>%
  group_by(race, gender) %>%
  na.omit() %>%
  summarise(n = n()) %>%
  ggplot(aes(x = as.factor(race), y = n, fill = gender)) +
  geom_bar(stat = "identity") + 
  scale_x_discrete(labels = c("1" = "Black/African American", "2" ="European/Caucasian-American", "3" = "Latino/Hispanic American", "4" = "Asian/Pacific \n Islander/Asian-American", "5" = "Native American", "6" = "Other")) +
  labs(title = "Raça e Gênero dos Participantes do Speed Dating", x = "Raça", 
       y = "Número de participantes", fill = "Gênero") +
  scale_fill_discrete(labels = c("Feminino", "Masculino")) + coord_flip()

## `summarise()` has grouped output by 'race'. You can override using the
## `.groups` argument.

Como observado, os participantes vão de jovens até adultos (mais concentrados na faixa de 20 a 30 anos), com a maioria sendo mulheres caucasianas.

Criando o modelo

Para investigar quais fatores têm efeito relevante na chance do casal ter match, vamos utilizar a regressão logística. Especialmente, vamos levar em consideração a coluna denominada dec, a qual representa a existência ou não (yes para sucesso e no para fracasso) de match entre os dois participantes do encontro. Esta será a variável de resposta.

Assim, analisando o formulário presente no repositório, podemos utilizar as seguintes variáveis para a criação do modelo:

order: será que os últimos serão os primeiros (a conseguir um date)?
attr: achar uma pessoa atraente é motivo forte para eu desejar ter um encontro depois?
intel: será que os nerds são fortes bons partidos?
fun: aquela velha história de que se você fizer alguém rir, você já tá mais perto de conquistá-la…

Agora vamos analisar a correlação entre essas variáveis e a variável de resposta dec.

cor_dados <- dados %>%
  select(order, attr, intel, fun, dec) %>%
  na.omit()
ggpairs(cor_dados)

## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.

De acordo com a matriz de correlação acima, não há indícios de pares de variáveis apresentando correlação muito alta. Assim, podemos selecioná-las para a construção de um modelo de regressão.

O modelo de regressão logística é verificado por:

modelo = glm(dec ~ order + attr + intel + fun, data = cor_dados, family = "binomial")
modelo

## 
## Call:  glm(formula = dec ~ order + attr + intel + fun, family = "binomial", 
##     data = cor_dados)
## 
## Coefficients:
## (Intercept)        order         attr        intel          fun  
##    -5.24456     -0.00559      0.56211     -0.08907      0.32797  
## 
## Degrees of Freedom: 4677 Total (i.e. Null);  4673 Residual
## Null Deviance:       6378 
## Residual Deviance: 4929  AIC: 4939

Como observado acima, os coeficientes de maior impacto no modelo são attr (0.56211) e fun (0.32797).

Vamos agora verificar o resultado do modelo considerando intervalos de confiança.

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

## # A tibble: 5 × 7
##   term        estimate std.error statistic   p.value conf.low conf.high
##   <chr>          <dbl>     <dbl>     <dbl>     <dbl>    <dbl>     <dbl>
## 1 (Intercept)  0.00528   0.231     -22.7   3.33e-114  0.00334   0.00825
## 2 order        0.994     0.00620    -0.902 3.67e-  1  0.982     1.01   
## 3 attr         1.75      0.0255     22.0   1.55e-107  1.67      1.85   
## 4 intel        0.915     0.0281     -3.17  1.54e-  3  0.866     0.967  
## 5 fun          1.39      0.0250     13.1   3.23e- 39  1.32      1.46

Para os atributos escolhidos, a ordem da pessoa no encontro não teve um efeito expressivo. Na verdade, pelo intervalo de confiança de 95% a ordem pode está entre 0,9824 e 1,0065, sendo um efeito pequeno e negativo ou irrisório. Semelhante acontece com a inteligência que com IC de 95% está entre 0,8655 e 0,9665, o efeito pode ser considerado mínimo e negativo. Os atributos que se destacaram foram o senso de humor, que chega a acrescentar até 0,4584 na fórmula do match (o valor estimado é de 1,3881 com IC de 95%[1,322, 1,4584]) e a aparência que neste modelo é o que mais importa com estimativa de 1,7543 e IC de 95%[1,6696, 1,8453].

Ou seja, ser bonito e engraçado conta mais que ser inteligente e o primeiro da fila. Mas ainda há esperanças para todos!

Conclusões

A seguir podemos verificar o quanto que o modelo criado representa sobre os dados:

pR2(modelo)

## fitting null model for pseudo-r2

##           llh       llhNull            G2      McFadden          r2ML 
## -2464.6051992 -3188.7593345  1448.3082705     0.2270959     0.2662595 
##          r2CU 
##     0.3577868

Para regressão logística não há \(R^2\), mas podemos estimar o valor de \(R^2\) para um modelo logístico. Com isso, verificamos através do método de McFadden que o modelo gerado explica apenas 26,41% dos dados, o que pode significar que as variáveis attr e fun podem não influenciar tanto na chance de match com algum participante.

Regressão Logística - Lab 4.2

Laryssa Kellen Filgueira Milanez

2022-06-16