Speed Dating

Motivação

Temos dados descrevendo 5000 encontros relâmpagos (speed dating, procura no google) de 4 minutos envolvendo 310 jovens americanos. Os dados originais foram coletados por professores da Columbia Business School no experimento descrito aqui. Aqui estamos usando uma versão com menos colunas para agilizar para vocês.

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.

Objetivo

O objetivo desse laboratório é você utilizar regressão logística com um conjunto de variáveis explicativas que você escolher (com no mínimo 4 variáveis) para responder o seguinte:

• Que fatores nos dados têm efeito relevante na chance do casal ter um match? Descreva se os efeitos são positivos ou negativos e sua magnitude.

Leitura do csv

data <- read_csv(here::here(params$arquivo_dados), col_types = 
                    cols(.default = col_double(), 
                         dec = col_character(),
                         from = col_character(),
                         field = col_character(),
                         career = col_character())) %>%
        mutate(gender = as.factor(gender),
               dec = as.factor(dec), 
               samerace = as.factor(samerace),
               race = as.factor(race))

Descrições das variáveis(colunas)

Abaixo descreveremos as colunas que temos no dataset importado acima.

Variável	Descrição
iid	ID do participante p1 no encontro
gender	Sexo do p1 (0 = mulher)
order	Número do encontro realizado em uma noite
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. Black/African American=1; European/Caucasian-American=2; Latino/Hispanic American=3; Asian/Pacific Islander/Asian-American=4; Native American=5; Other=6
from	Local de onde p1 é
career	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

Abaixo realizaremos uma análise estatística descritiva rápida e resumida dos nossos dados para entender melhor as características deles.

skimr::skim(data)

Data summary

Name	data
Number of rows	4918
Number of columns	44
_______________________
Column type frequency:
character	3
factor	4
numeric	37
________________________
Group variables	None

Variable type: character

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

Variable type: factor

skim_variable	n_missing	complete_rate	ordered	n_unique	top_counts
gender	0	1	FALSE	2	1: 2464, 0: 2454
samerace	0	1	FALSE	2	0: 2920, 1: 1998
race	20	1	FALSE	5	2: 2843, 4: 1111, 3: 399, 6: 301
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	▁▅▇▇▂
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	▃▇▆▁▁
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	▂▂▅▃▇

Logo em seguida, escolheremos em torno de 15 variáveis para analisá-las e entendermos a distribuição de algumas delas em relação a variável dependente dec.

# Definindo array com algumas variáveis
variables <- c("order", "age", "age_o", "exercise", "attr", "attr3_s",
               "sinc", "sinc3_s", "intel", "intel3_s", "fun", "fun3_s",
               "shar", "like", "prob")


data_without_na <- na.omit(data)


# Converter a variável dependente para numérica
data_without_na$dec_numeric <- as.numeric(data_without_na$dec) - 1  # Convertendo "no" para 0 e "yes" para 1


correlations <- sapply(variables, function(var) {
  cor(data_without_na[[var]], data_without_na$dec_numeric)
})

correlations

##        order          age        age_o     exercise         attr      attr3_s 
## -0.049384928 -0.043446842 -0.093770147 -0.003422209  0.472172758  0.021237388 
##         sinc      sinc3_s        intel     intel3_s          fun       fun3_s 
##  0.259807843  0.029525229  0.224389867  0.078624912  0.388371329  0.016705004 
##         shar         like         prob 
##  0.389618190  0.541358294  0.336660223

cor_df <- data.frame(`Variável` = variables, `Correlação` = correlations)


cor_df <- cor_df %>% arrange(desc(Correlação))

print(cor_df)

##          Variável   Correlação
## like         like  0.541358294
## attr         attr  0.472172758
## shar         shar  0.389618190
## fun           fun  0.388371329
## prob         prob  0.336660223
## sinc         sinc  0.259807843
## intel       intel  0.224389867
## intel3_s intel3_s  0.078624912
## sinc3_s   sinc3_s  0.029525229
## attr3_s   attr3_s  0.021237388
## fun3_s     fun3_s  0.016705004
## exercise exercise -0.003422209
## age           age -0.043446842
## order       order -0.049384928
## age_o       age_o -0.093770147

Após observar a correlação, iremos escolher 5 seguintes variáveis:

• like;
• attr;
• shar;
• fun;
• prob;

visto que no dataframe acima foram obtiveram melhor correlação.A seguir iremos analisar a correlação entre as variáveis escolhidas.

e além dessas variáveis, consideraremos também a variável:

• gender

library(GGally)

## Registered S3 method overwritten by 'GGally':
##   method from   
##   +.gg   ggplot2

chosen_data <- data %>% 
  select(dec, gender, like, attr, shar, fun, prob) %>%
  na.omit() %>%
  mutate(dec_numeric = case_when(.$dec == "no" ~ 0,
                         .$dec == "yes" ~ 1))  
ggpairs(chosen_data)

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

Nesse momento, iremos realizar o particionamento treino e teste. O particionamento foi realizando considerando 80% para treinamento e 20% para testes

 # 20% dos dados serão usados para teste
test_ratio <- 0.2 

# Criar os índices para a divisão entre treinamento e teste
set.seed(123)

train_indices <- createDataPartition(chosen_data$dec_numeric, p = 1 - test_ratio, list = FALSE)


# Dividir os dados em conjuntos de treinamento e teste
train_data <- chosen_data[train_indices, ]
test_data <- chosen_data[-train_indices, ]


num_amostras <- data.frame(Conjunto = c("Treino", "Testes"),
                           Num_Amostras = c(nrow(train_data), nrow(test_data)))

num_amostras

##   Conjunto Num_Amostras
## 1   Treino         3378
## 2   Testes          844

Criar Modelo com Regressão logística

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

model <- glm(dec_numeric ~ gender + like + attr +  shar + fun + prob,
              data = train_data,
              family = "binomial")

summary(model)

## 
## Call:
## glm(formula = dec_numeric ~ gender + like + attr + shar + fun + 
##     prob, family = "binomial", data = train_data)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -3.0022  -0.7716  -0.2653   0.7956   3.1050  
## 
## Coefficients:
##              Estimate Std. Error z value Pr(>|z|)    
## (Intercept) -7.607688   0.278965 -27.271  < 2e-16 ***
## gender1      0.408760   0.087330   4.681 2.86e-06 ***
## like         0.508528   0.044089  11.534  < 2e-16 ***
## attr         0.403093   0.033221  12.134  < 2e-16 ***
## shar         0.112408   0.028357   3.964 7.37e-05 ***
## fun          0.002123   0.033654   0.063     0.95    
## prob         0.143278   0.024431   5.865 4.50e-09 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 4593.6  on 3377  degrees of freedom
## Residual deviance: 3206.4  on 3371  degrees of freedom
## AIC: 3220.4
## 
## Number of Fisher Scoring iterations: 5

Com base nessas conclusões, é possível afirmar que as variáveis:

• “gender1”;

• “like”;

• “attr”;

• “shar”;

• “prob”

têm efeitos relevantes na chance de um “match”. No entanto, a variável “fun” não parece ter uma relação significativa. Portanto, iremos excluir a variável “fun” do modelo e treiná-lo novamente considerando apenas as variáveis significativas restantes.

model <- glm(dec_numeric ~ gender + like + attr + prob + shar + prob,
              data = train_data,
              family = "binomial")

summary(model)

## 
## Call:
## glm(formula = dec_numeric ~ gender + like + attr + prob + shar + 
##     prob, family = "binomial", data = train_data)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -3.0021  -0.7714  -0.2655   0.7956   3.1043  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) -7.60508    0.27585 -27.569  < 2e-16 ***
## gender1      0.40896    0.08727   4.686 2.79e-06 ***
## like         0.50949    0.04138  12.314  < 2e-16 ***
## attr         0.40346    0.03270  12.339  < 2e-16 ***
## prob         0.14336    0.02440   5.876 4.19e-09 ***
## shar         0.11282    0.02761   4.086 4.40e-05 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 4593.6  on 3377  degrees of freedom
## Residual deviance: 3206.4  on 3372  degrees of freedom
## AIC: 3218.4
## 
## Number of Fisher Scoring iterations: 5

Para entender melhor os coeficientes no contexto das funções logísticas, examinaremos os coeficientes aplicando a função exponencial:

exp(model$coefficients)

##  (Intercept)      gender1         like         attr         prob         shar 
## 0.0004979167 1.5052464347 1.6644416941 1.4970015573 1.1541450941 1.1194250865

Com base nos coeficientes do modelo de regressão logística, podemos concluir o seguinte:

• A variável gender1 possui um coeficiente estimado de 1.5052464347, o que indica que um aumento unitário na pontuação de gender está associado a um aumento de aproximadamente 1.50 vezes na probabilidade da variável dependente(dec), ou seja, aumenta a possibilidade de match.

• A variável like possui um coeficiente estimado de 1.6644416941, o que indica que um aumento unitário na pontuação de like está associado a um aumento de aproximadamente 1.66 vezes na probabilidade da variável dependente(dec), ou seja, aumenta a possibilidade de match.

• A variável attr possui um coeficiente estimado de 1.4970015573, o que indica que um aumento unitário na pontuação de attr está associado a um aumento de aproximadamente 1.50 vezes na probabilidade da variável dependente(dec), ou seja, aumenta a possibilidade de match.

• A variável prob possui um coeficiente estimado de 1.1541450941, o que indica que um aumento unitário na pontuação de prob está associado a um aumento de aproximadamente 1.15 vezes na probabilidade da variável dependente(dec), ou seja, aumenta a possibilidade de match.

• Em contrapatida, a variável shar possui um coeficiente estimado de 1.1194250865, o que indica que um aumento unitário na pontuação de shar está associado a um aumento de aproximadamente 1.12 vezes na probabilidade da variável dependente(dec), no entanto, seu impacto é menor em comparação com as outras variáveis. O coeficiente estimado para “shar” indica um efeito positivo menor na probabilidade de um “match” ocorrer.

Podemos ratificar o argumento acima, ilustrando da seguinte maneira

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

A seguir, iremos submeter o conjunto de testes ao modelo

model_test <- augment(model,
                 newdata = test_data,
                 type.predict = "response")

model_test

## # A tibble: 844 × 9
##    dec   gender  like  attr  shar   fun  prob dec_numeric .fitted
##    <fct> <fct>  <dbl> <dbl> <dbl> <dbl> <dbl>       <dbl>   <dbl>
##  1 yes   0          7     7     8     7     6           1 0.634  
##  2 yes   0          6     7     7     4     5           1 0.446  
##  3 no    0          8     6     8     9     6           0 0.658  
##  4 no    0          8     7     7     7     7           0 0.748  
##  5 yes   0         10     9     5     9     3           1 0.892  
##  6 no    0          6     4     2     4     2           0 0.0815 
##  7 no    0          2     3     1     1     2           0 0.00685
##  8 yes   0          9     8     7     9     8           1 0.895  
##  9 no    0          7     4     4     5     4           0 0.198  
## 10 yes   0          8     7     6     7     6           1 0.697  
## # ℹ 834 more rows

A análise gráfica a seguir visa examinar os resultados obtidos em relação aos valores esperados, considerando a distinção entre gêneros. O gráfico está dividido em duas partes:

• a primeira parte utilizando o valor 0 para representar o gênero feminino;

• a segunda parte utilizando o valor 1 para o gênero masculino.

Nosso objetivo é identificar possíveis disparidades na capacidade do modelo em prever corretamente as classes em relação a esses grupos.

Ao observar o gráfico, buscamos indícios de diferenças significativas nas previsões com base no gênero. No entanto, não encontramos evidências substanciais de discrepâncias nas previsões do modelo entre os gêneros, sugerindo que o modelo tem desempenho consistente e equilibrado em termos de predição para ambas as classes de gênero.

ggplot(model_test, aes(x = .fitted, y = dec_numeric)) +
  geom_point(alpha = .1) +
  stat_smooth(method = "glm", se = FALSE, method.args = list(family = binomial), col = "red", lty = 2) +
  facet_grid(. ~ reorder(gender, .fitted)) +
  labs(x = "Valores Ajustados", y = "Decisão de Match (Sim/Não)")

## `geom_smooth()` using formula = 'y ~ x'

Acurácia

Em seguida, realizamos o cálculo da acurácia do modelo de teste para avaliar sua precisão na classificação. A acurácia é uma métrica que mede a proporção de predições corretas em relação ao total de predições realizadas.

# Converter as previsões e rótulos corretos em fatores com os mesmos níveis
predictions <- model_test$.fitted
true_labels <- model_test$dec_numeric

predictions <- ifelse(predictions > 0.5, 1, 0)
predictions <- factor(predictions, levels = c(0, 1))
true_labels <- factor(true_labels, levels = c(0, 1))


conf_matrix <- confusionMatrix(predictions, true_labels, mode = "everything")

accuracy <- conf_matrix$overall['Accuracy']
recall <- conf_matrix$byClass['Recall']
f1_score <- conf_matrix$byClass['F1']


print(paste("Acurácia do modelo de teste:", round(accuracy * 100, 2), "%"))

## [1] "Acurácia do modelo de teste: 76.78 %"

print(paste("F1 score:", round(f1_score, 2)))

## [1] "F1 score: 0.8"

print(paste("Recall:", round(recall, 2)))

## [1] "Recall: 0.82"

df_accuracy <- data.frame(Acurácia = accuracy)

# Criar o gráfico de barras
barplot(df_accuracy$Acurácia, names.arg = df_accuracy$Categoria,
        main = "Acurácia do Modelo", ylab = "Acurácia", ylim = c(0, 1))

text(1, df_accuracy$Acurácia, labels = paste0(round(df_accuracy$Acurácia * 100, 2), "%"),
     pos = 3)

Conclusões

Após a análise dos resultados da regressão logística, constatamos que o modelo apresentou uma taxa de acurácia de 75%. Essa métrica nos permite avaliar o desempenho do modelo em relação à sua capacidade de fazer previsões precisas das classes. Com uma acurácia de 75%, podemos considerar que o modelo apresenta um nível razoável de confiabilidade na sua capacidade de prever corretamente se haverá um “match” ou não.