Dados Speed-Dating

O Speed-Dating é um programa americano de encontros de pessoas solteiras. O objetivo do programa é fornecer encontros de pessoas cadastradas de forma dinâmica, onde há uma rotatividade de encontros até formar casais.

Usaremos dados de algum desses encontros:

dadosSpeed <- read_csv(here("speed-dating/speed-dating2.csv"))

## Parsed with column specification:
## cols(
##   .default = col_double(),
##   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()
## )

## See spec(...) for full column specifications.

glimpse(dadosSpeed)

## Rows: 4,918
## Columns: 44
## $ iid      <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2…
## $ gender   <dbl> 0, 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, 8,…
## $ pid      <dbl> 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 11, 12, 13, 14,…
## $ 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, 1…
## $ age_o    <dbl> 27, 22, 22, 23, 24, 25, 30, 27, 28, 24, 27, 22, 22, 23,…
## $ age      <dbl> 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 24, 24, 24, 24,…
## $ 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, 2…
## $ from     <chr> "Chicago", "Chicago", "Chicago", "Chicago", "Chicago", …
## $ career   <chr> "lawyer", "lawyer", "lawyer", "lawyer", "lawyer", "lawy…
## $ sports   <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 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, 2…
## $ exercise <dbl> 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 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, 1…
## $ museums  <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 8, 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, 6…
## $ hiking   <dbl> 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 3, 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, 5…
## $ clubbing <dbl> 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 8, 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, 1…
## $ tv       <dbl> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 1, 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, 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, 8…
## $ shopping <dbl> 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 3, 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, 1…
## $ attr     <dbl> 6, 7, 5, 7, 5, 4, 7, 4, 7, 5, 5, 8, 5, 7, 6, 8, 7, 5, 7…
## $ sinc     <dbl> 9, 8, 8, 6, 6, 9, 6, 9, 6, 6, 7, 5, 8, 9, 8, 7, 5, 8, 6…
## $ intel    <dbl> 7, 7, 9, 8, 7, 7, 7, 7, 8, 6, 8, 6, 9, 7, 7, 8, 9, 7, 8…
## $ fun      <dbl> 7, 8, 8, 7, 7, 4, 4, 6, 9, 8, 4, 6, 6, 6, 9, 3, 6, 5, 9…
## $ 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, 5…
## $ like     <dbl> 7, 7, 7, 7, 6, 6, 6, 6, 7, 6, 6, 7, 6, 7, 8, 6, 8, 5, 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, 3…
## $ attr3_s  <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,…
## $ sinc3_s  <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,…
## $ intel3_s <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,…
## $ fun3_s   <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,…
## $ amb3_s   <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,…
## $ dec      <chr> "yes", "yes", "yes", "yes", "yes", "no", "yes", "no", "…

Explanando os dados

Antes de começarmos o experimento, é necessário que se faça uma análise descritiva dos dados, sendo assim será plotado algumas visualizações para sabermos as características dos participantes.

dadosSpeed %>% 
  group_by(age) %>% 
  summarise(quantidade = n()) %>% 
  ggplot(mapping = aes(x = age, y = quantidade)) + 
  geom_bar(stat = "identity") + 
  labs(title = "Número de participantes por idade",
       x = "Idade",
       y = "Quantidade") + 
   theme(plot.title = element_text(hjust = 0.5))

Observando o gráfico acima, percebe-se que os participantes do programa são majoritariamente jovens, tendo como maioria jovens de 23 anos e a grande maioria concentrada entre os 21 e os 30 anos.

dadosFactor <- dadosSpeed %>% 
  mutate(gender = as.factor(gender),
         race = as.factor(race),
         dec = as.factor(dec))

dadosFactor %>% 
  group_by(gender) %>% 
  summarise(quantidade = n()) %>% 
  ggplot(mapping = aes(x = gender, y = quantidade, fill = gender)) +
  geom_bar(stat = "identity") + 
  scale_fill_discrete(labels = c("Masculino", "Feminino")) +
  labs(title = "Número de participantes por gênero",
       x = "Gênero",
       y = "Quantidade") + 
   theme(plot.title = element_text(hjust = 0.5))

Segundo o gráfico acima, o número de participantes por gênero está bem dividido. Por isso, não há uma dominânia de nenhum dos gêneros analisados.

dadosSpeed %>% 
  group_by(from) %>% 
  summarise(quantidade = n()) %>% 
  filter(quantidade > 100) %>% 
  ggplot(mapping = aes(x = from, y = quantidade)) + 
  geom_bar(stat = "identity", fill = "darkred") + 
  labs(title = "Número de participantes por local de origem",
       x = "Local de origem",
       y = "Quantidade") + 
   theme(plot.title = element_text(hjust = 0.5))

Analisando o lugar de onde os participantes pertecem, vemos uma dominância dos estados de Nova Iorque, Nova Jersey e na California. Destaca-se a participação de Itália e Israel que são dois lugares fora da América, mas contém muitos participantes.

dadosSpeed %>% 
  group_by(career) %>% 
  summarise(quantidade = n()) %>% 
  filter(quantidade > 100) %>% 
  ggplot(mapping = aes(x = career, y = quantidade)) + 
  geom_bar(stat = "identity", fill = "darkblue") + 
  labs(title = "Número de participantes por carreira",
       x = "Carreira",
       y = "Quantidade") + 
   theme(plot.title = element_text(hjust = 0.5))

Em relação a profissão dos participantes, temos advogado(a) como principal ocupação dos participantes, seguido por trabalho social e professor(a).

dadosFactor %>% 
  group_by(race) %>% 
  summarise(quantidade = n()) %>% 
  na.omit() %>% 
  ggplot(mapping = aes(x = race, y = quantidade, fill = race)) + 
  geom_bar(stat = "identity") + 
  scale_fill_discrete(labels = c("1" = "Afro-americano", "2" = "Caucasiano-americano", "3" = "Hispânico-americano", "4" = "Asiático-americano", "5" = "Nativo-americano", "6"="Outro")) +
  labs(title = "Número de participantes por raça",
       x = "Raça",
       y = "Quantidade") + 
   theme(plot.title = element_text(hjust = 0.5))

Por fim, a análise pela raça dos participantes mostrou uma soberania de americanos caucasianos com destaque para a baixa participação de afro-americanos.

Criando o modelo

Para essa análise, utilizaremos um modelo de regressão logística. Pois a regressão logística é uma técnica recomendada para situações em que a variável dependente é de natureza binária, assim como a variável dec. Sendo assim, usaremos as seguintes variáveis:

shar: Nível de compartilhamento de intresses e hobbies
fun: Quão divertido a outra pessoa foi
attr: Quão atraente era a outra pessoa
prob: Probabilidade de se encontrar novamente com a outra pessoa
dec: Se deu match ou não

Sendo assim, iremos analisar a correlação entre essas variáveis.

dadosModelo  <- dadosFactor %>% 
  select(shar, fun, attr, prob, dec)
ggpairs(dadosModelo)

## `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`.

Criando o modelo com as variáveis escolhidas, temos:

modeloSpeed = glm(dec ~ shar + fun + attr + prob,
                  data = dadosModelo,
                  family = "binomial")

tidy(modeloSpeed, conf.int = TRUE, exponentiate = TRUE, conf.level = 0.95)

Descrição do modelo: A regressão logística foi utilizada para analisar se o fato de dar match ou não está correlacionado com nível de compartilhamento de intresses e hobbies (shar), quão divertido a outra pessoa foi (fun), quão atraente era a outra pessoa (attr), probabilidade de se encontrar novamente com a outra pessoa (prob). Ao analisar os resultados obtidos temos que com 95% de confiança podemos afirmar que o fato da outra pessoa compartilhar os memos hobbies, de ser engraçada e a probabilidade de se encontrar novamente têm uma relação média, tendo shar um valor estimado de 1.237126138 e intervalo de [1.281296430, 1.403136349], e fun um valor estimado de 1.126927531 e um intervalo de [1.158777101, 1.297710948] e em relação a prob tem um valor estimado de 1.214500913 e um IC de [1.1660722521, 1.265347845]. Por fim, em relação a outra pessoa ser atraente tem a relação mais forte entre as variáveis analisadas com valor estimado de 1.727208750 IC de [1.6362173085, 1.825382089].

Desse modo, iremos calcular a porcentagem do quanto o nosso modelo explica os dados analisados através do modelo R² de McFadden:

pR2(modeloSpeed)

## fitting null model for pseudo-r2

##           llh       llhNull            G2      McFadden          r2ML 
## -2105.4318286 -2880.6466072  1550.4295571     0.2691114     0.3071665 
##          r2CU 
##     0.4127103

O modelo representa apenas 27% dos dados, aproximadamente. Ou seja, não é aconselhável tomar decisões confiáveis a partir do modelo proposto

Regressão Logistica Variaveis Explicativas

Mattheus Brito

Dados Speed-Dating

Explanando os dados

Criando o modelo