Análise descritiva

s <- speed %>% 
  select(dec, attr, shar, fun, sinc, amb, intel, samerace) %>%
  mutate(id = row_number()) %>%
  relocate(id, .before=dec) %>%
  pivot_longer(
   cols = c(attr, shar, fun, intel, sinc, amb),
   names_to = "aspect",
   values_to = "score"
  ) %>%
  filter(!is.na(score))

s$aspect[s$aspect == "attr"] <- "Atraente"
s$aspect[s$aspect == "shar"] <- "Compartilha interesses/hobbies"
s$aspect[s$aspect == "fun"] <- "Divertido"
s$aspect[s$aspect == "sinc"] <- "Sincero"
s$aspect[s$aspect == "amb"] <- "Ambicioso"
s$aspect[s$aspect == "intel"] <- "Inteligente"

s$samerace[s$samerace == 0] <- "Não"
s$samerace[s$samerace == 1] <- "Sim"

Como dito anteriormente, as variáveis que foram escolhidas se relacionam às impressões dos participantes acerca de características do parceiro nos encontros (foram quantificadas de 0 a 10, isto é, do mínimo ao máximo de expressão da característica). Elas se tratam de: quão divertido, sincero, ambicioso, atraente, inteligente e o quão o parceiro compartilha interesses/hobbies. Por curiosidade, também avaliamos as proporções de encontros entre participantes da mesma raça. Como os participantes não eram obrigados a preencher tudo, só trabalharemos com os encontros onde todas as avaliações são diferentes de NA (n = 4133).

Mas antes de partir para o modelo, primeiro é melhor se ter uma boa ideia do formato de suas distribuições. Para se ter uma visão geral, mas incompleta da situação, podemos usar um gráfico de pontos.

p <- 
  ggplot(s, aes(score, reorder(aspect, score), 
                color = aspect, fill = aspect)) + 
  scale_x_continuous(breaks = 0:10) +
  guides(fill = "none", color = "none") +
  labs(
    x = "Nota",
    y = "",
    title = "Distribuição de avaliações"
  )

p + geom_jitter(size = 0.2, width = 0.2, alpha = .2) +
    labs(
      subtitle = "Gráfico de pontos"
    )

Como podemos ver, os dados estão distribuídos de forma relativamente discreta em cada nota de 0 a 10 (cada retângulo de pontos está associado à nota inteira abaixo), existem algumas pouquíssimas exceções com notas decimais (algumas .5). As notas extremas, principalmente à esquerda, são mais incomuns, o que revela distribuições mais concentradas à direita, com exceção do compartilhamento de interesses. Com isso em mente, gráficos de densidade com linha de mediana e uma tabela de estatísticas nos mostrarão melhor o formato e características das concentrações entre os aspectos.

p +
  ggridges::geom_density_ridges(
    alpha = .9, size = 1, bandwidth = 0.6, 
    rel_min_height = 0.01, quantile_lines = TRUE, 
    quantiles = 2, color = "black"
  ) +
  labs(
    subtitle = "Gráfico de densidades com linha da mediana"
  )

s %>%
  group_by(aspect) %>%
  summarise("Média" = round(mean(score), 2),
            "Mediana" = round(median(score), 2),
            "Desvio Padrão" = round(sd(score), 2),
            "90-percentil" = quantile(score, .9)) %>%
  rename("Aspecto" = aspect) %>%
  kbl() %>%
  kable_styling(font_size = 13, full_width = F)

De forma geral, realmente as distribuições são mais concentradas à direita (medianas e médias maiores que 5), com exceção do aspecto de compartilhamento de interesses, que parece mais simétrico que os outros, como também apresenta o maior desvio padrão. Já as avaliações de sinceridade, ambição e inteligência parecem as características mais concentradas em valores maiores. Quanto ao aspecto de diferença de raças, aqui está um gráfico de barras para melhor visualização.

s %>%
  select(id, samerace) %>%
  unique %>%
  mutate(tot = n()) %>%
  group_by(samerace) %>%
  summarise(freq_abs = n(), freq_r = n() / tot) %>%
  unique %>%
  ggplot(aes(x = reorder(samerace, freq_abs), freq_abs), 
             y = freq_abs) +
  geom_chicklet(aes(fill = samerace), width = 0.4, 
                radius = grid::unit(6, "pt")) +
  geom_text(aes(label = paste(round(freq_r * 100, 2), "%")), 
            position = position_dodge(width = 0.2), 
            vjust = 0.4, hjust = 1.2, 
            size = 7, color = "white") +
  labs(
    x = "Mesma raça",
    y = "Frequência",
    title = "Proporção de pares com mesma raça"
  ) +
  guides(fill = "none") +
  scale_y_continuous(limits = c(0, 3000)) +
  coord_flip() 

Observamos que a maior parte dos participantes (59.76%) não é da mesma raça, enquanto 40.63% são da mesma raça. Esse aspecto pode nos parecer estranho de ser analisado no Brasil, pois não costumamos discutir muito sobre raça em relacionamentos, mas em outros países (como nos EUA) essa discussão é bem mais calorosa.

Modelo logístico

Agora partiremos para a seção mais empolgante, onde modelamos a decisão de se encontrar novamente. Para isso criamos um modelo com a linguagem R onde as variáveis e seus coeficientes estão abaixo.

set.seed(123)

matches = glm(dec ~ attr + shar + fun + sinc + 
                    amb + intel + samerace, 
                  data = speed, 
                  family = "binomial")

cffs <- tidy(matches, exponentiate = T, conf.int = T)
cffs_aux <- tidy(matches, conf.int = T)

cffs$term[cffs$term == "attr"] <- "Atraente (attr)"
cffs$term[cffs$term == "amb"] <- "Ambicioso (amb)"
cffs$term[cffs$term == "shar"] <-"Compartilha interesses (shar)"
cffs$term[cffs$term == "fun"] <- "Divertido (fun)"
cffs$term[cffs$term == "sinc"] <- "Sincero (sinc)"
cffs$term[cffs$term == "intel"] <- "Inteligente (intel)"
cffs$term[cffs$term == "samerace"] <- "Mesma Raça (sr)"

cbind(
  cffs %>%
    select(term, estimate, conf.low, conf.high),
  cffs_aux %>%
    select(estimate) %>%
    rename("estimativa" = estimate)
) %>%
  relocate(estimativa, .before = estimate) %>%
  mutate("IC 95% (e^Estimativa)" = 
           paste("[", round(conf.low, 4), ", ", 
                 round(conf.high, 4), "]", sep = ""),
         estimativa = round(estimativa, 4),
         estimate = round(estimate, 4)) %>%
  select(-c(conf.low, conf.high)) %>%
  rename("Termo" = term, 
         "Estimativa" = estimativa, 
         "e^Estimativa" = estimate) %>%
  kbl() %>%
  kable_styling(font_size = 13)

Esse modelo tem um pseudo-r2 (McFadden) de 0.2643 (26.43%), ou seja, consegue explicar 26.43% da variação das decisões entre se encontrar ou não depois da reunião rápida. Quanto a sua estrutura, o modelo tem o seguinte formato (y representa a probabilidade condicional de aceitar o encontro dados os valores dos termos):

\(y = \frac{e^{-5.08 + 0.56*attr + 0.32*shar + 0.26*fun - 0.13 * sinc - 0.19 * amb + 0.006 * intel - 0.08 * sr}}{1 + e^{-5.08 + 0.56*attr + 0.32*shar + 0.26*fun - 0.13 * sinc - 0.19 * amb + 0.006 * intel - 0.08 * sr}}\)

Do qual podemos derivar a seguinte relação:

\(\frac{y}{1 - y} = 0.0062 * 1.76^{attr} * 1.38^{shar} * 1.29^{fun} * 0.88^{sinc} * 0.82^{amb} * 1.006^{intel} * 0.92^{sr}\)

Agora partiremos para interpretar a influência desses termos na probabilidade condicional de aceitar o encontro. Primeiro, temos que entender o lado esquerdo da equação acima, que diz respeito à razão entre a probabilidade de decidir sim para o encontro, dados os termos, e seu complemento (probabilidade de decidir não, dados os termos). Isso geralmente é referido como “odds” em inglês (e.g. odds de 7:1 significam que a cada 8 eventos estimamos que 7 vão resultar no evento A e 1 no evento B), ou seja, se o lado esquerdo for maior que o direito, esse lado tem mais probabilidade de acontecer que o outro (⅞ > ⅛).

Já do lado direito da equação temos que cada vez que um expoente de um certo termo é somado de 1, os odds são multiplicados pela base do respectivo termo. Quando o termo que multiplica é maior que 1, os odds de se conseguir um encontro depois aumentam e entre 0 e 1 os odds diminuem.

Armados desse conhecimento, vemos que na nossa amostra os mais importantes em ordem decrescente são ser atraente, compartilhar interesses, ser divertido e inteligente (aumentando em 76%, 38%, 29% e 0.6% respectivamente, os odds no caso de aumento de 1 unidade dessas variáveis), enquanto ser da mesma raça (-7.9%), sincero (-12%) e ambicioso (-18%) tem efeitos negativos.

Por fim, vamos avaliar os possíveis valores na população através dos intervalos de confiança:

cffs %>%
    filter(term != "(Intercept)") %>%
    ggplot(aes(x = reorder(term, estimate), 
               y = estimate, 
               ymin = conf.low, 
               ymax = conf.high)) +
    geom_linerange(size = .7) +
    geom_point(color = "chocolate3", size = 2.5, alpha = 1) +
    geom_text(aes(label = paste("[", round(conf.low, 2), ", ", 
                                round(conf.high, 2), "]", sep = "")), 
              nudge_x = -0.2, nudge_y = 0.05, size = 3.4) +
    coord_flip() +
    labs(
        x = "Termos do modelo",
        y = "Estimativa",
        title = "e^Estimativas do modelo"
    )

Estimamos que, na prática, a sinceridade e a ambição são menores do que 1, consequentemente para maximizar suas chances em encontros, provavelmente deve-se evitar ser muito sincero ou ambicioso de início. Quanto à questão da raça e da inteligência, tanto podem apresentar efeito consideravelmente negativos como levemente positivos. Já em relação a ser atraente, compartilhar interesses/hobbies e ser divertido, pessoas atraentes parecem estar associadas com odds bem melhores que o restante. Enquanto compartilhar interesses e ser divertido estão empatados técnicamente.