L5P3: Regressão romântica

Carregamento do dados

Explorando dados para escolha de fatores

Dentre as informações presentes nesses dados, encontram-se informações sobre o que o avaliador achou do avaliado quanto à atração, sinceridade, ser engraçado, ambicioso e inteligente. Esses são fatores que provavelmente estão bem relacionados com a decisão de se encontrar novamente. Para analisar se isso se verifica na amostra de dados, esses foram plotados para cada uma dessa características.

No gráfico abaixo, é plotado o quão sincero o avaliador achou o avaliado em relação a se houve um encontro novamente.

dating %>% 
    drop_na(sinc)  %>% 
    ggplot(aes(x = sinc, y = dec)) + 
    geom_count() +
    NULL

No seguinte, plotou-se o quão engraçado o avaliador achou o avaliado. Percebe-se uma diferença quanto ao gráfico de sinceridade, há mais valores entre 7.5 e 10 - acha a pessoa bem engraçada - quando o encontro de fato aconteceu.

dating %>% 
    drop_na(fun)  %>% 
    ggplot(aes(x = fun, y = dec)) + 
    geom_count() +
    NULL

O gráfico a seguir é referente à atração que o avaliador senteiu pelo avaliado.

dating %>% 
    drop_na(attr)  %>% 
    ggplot(aes(x = attr, y = dec)) + 
    geom_count() +
    NULL

O gráfico a seguir é referente a quão ambicioso o avaliador achou o avaliado.

dating %>% 
    drop_na(amb)  %>% 
    ggplot(aes(x = amb, y = dec)) + 
    geom_count() +
    NULL

A seguir, o gráfico é referente a quão inteligente o avaliador achou o avaliado.

dating %>% 
    drop_na(intel)  %>% 
    ggplot(aes(x = intel, y = dec)) + 
    geom_count() +
    NULL

A seguir, o gráfico é referente à quanto o avaliador achou que compartilha interesses e hobbies com o avaliado.

dating %>% 
    drop_na(shar)  %>% 
    ggplot(aes(x = shar, y = dec)) + 
    geom_count() +
    NULL

Além dessas características, quiz se adicionar ao modelo o fator gênenro do avaliador.

dating %>% 
    drop_na(gender)  %>% 
    ggplot(aes(x = gender, y = dec)) + 
    geom_count() +
    NULL

O modelo

Após escolher os fatores que apresentam certa diferença entre se encontrar novamente (yes) ou não se encontrar novamente (no), podemos estimar um modelo baseado nesses fatores.

Para isso, os dados de interesse foram filtrados. A informação se houve ou não encontro novamente foi codificada em 1 e 0.

dating <- dating %>% 
  select(dec, gender, sinc, fun, intel, amb, attr, shar) %>%
  na.omit() %>%
  mutate(dec = ifelse(dec=="yes", 1, 0)) 

Foi então estimado o modelo por regressão logística:

\(\frac{p(dec)}{1 - p(dec)} = 0.005 * 1.38^{shar} 1.01^{intel} 0.83^{amb} 1.28^{fun} 1.74^{attr} 0.87^{sinc} 1.35^{gender}\)

Cada variável está mostrada abaixo:

sinc: quão sincero p1 achou p2

fun: quão divertido p1 achou p2

attr: quão atraente p1 achou p2

amb: quão ambicioso p1 achou p2

shar: quanto p1 achou que compartilha interesses e hobbies com p2

intel: quão inteligente p1 achou p2

A tabela a seguir mostra os coeficientes obtidos assim como os intervalos de confiança.

bm <- glm(dec ~ gender + sinc + fun + intel + amb + attr + shar, 
          data = dating, 
          family = "binomial")

tidy(bm, conf.int = TRUE, exponentiate = TRUE) %>% select(-p.value)

glance(bm)

pR2(bm)

fitting null model for pseudo-r2
          llh       llhNull            G2      McFadden          r2ML          r2CU 
-2062.0922894 -2812.7409190  1501.2972594     0.2668744     0.3048908     0.4097735 

Com a tabela e a figura abaixo, podemos entender melhor a contribuição de cada fator para o modelo estimado. O fator que apresenta maior efeito no “match” é a atração assumindo um coeficiente entre 1.64 e 1.84. EM seguida vem os fatores gênero, o quâo engraçada a pessoa foi e os assuntos em comuns que elas tem. A não ser pelo gênero, esses fatores já eram esperado que contribuissem para um match. Os fatores que impressinaram foi a inteligência que não representa nem um comportamento positivo nem negativo no match pois o intervalo de confiança apresenta essa incerteza (valores menores e maiores que 1). Em seguida, vem a sinceridade e ambição que geram um efeito de diminuição de probabilidade de dar o match.

tidy(bm, conf.int = TRUE, exponentiate = TRUE) %>% 
  filter(term != "(Intercept)") %>% 
  ggplot(aes(x = reorder(term, estimate), y = estimate, ymin = conf.low, ymax = conf.high)) + 
  geom_point() + 
  geom_linerange() + 
  coord_flip()