relatorio-final

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.1     ✔ readr     2.1.4
## ✔ forcats   1.0.0     ✔ stringr   1.5.0
## ✔ ggplot2   3.4.2     ✔ tibble    3.2.1
## ✔ lubridate 1.9.2     ✔ tidyr     1.3.0
## ✔ purrr     1.0.1     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the ]8;;http://conflicted.r-lib.org/conflicted package]8;; to force all conflicts to become errors
## 
## Attaching package: 'modelr'
## 
## 
## The following object is masked from 'package:broom':
## 
##     bootstrap
## 
## 
## Classes and Methods for R developed in the
## Political Science Computational Laboratory
## Department of Political Science
## Stanford University
## Simon Jackman
## hurdle and zeroinfl functions by Achim Zeileis
## 
## Type 'citation("pROC")' for a citation.
## 
## 
## Attaching package: 'pROC'
## 
## 
## The following objects are masked from 'package:stats':
## 
##     cov, smooth, var

A ATIVIDADE

Neste laboratório será criado e analisado um modelo de regressão logística que busca compreender quais variáveis influenciam mais ou menos na compatibilidade de um casal dada a situação de um primeiro encontro, também conhecido como speed dating.

Speed dating pode ser definido como encontros “relâmpago”, de curto tempo, de pessoas solteiras com objetivo de gerar “matches” e , talvez, formar casais compatíveis. Inicialmente, os encontros tem duração de 4 minutos e após decorrido este tempo os pares são permutados até que todos tenham se conhecido. Ao fim do processo, é esperado que alguns casais se formem para encontros com maior duração.

O dataset trabalhado foi coletado por professores da Columbia Business School, e é composto pela resposta dos participantes a fichas avaliando aqueles com quem se encontraram. Cada linha nos dados representa um desses encontros.

OBJETIVOS:

Analisar e compreender 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.

Algumas dicas:

• Lembre que temos apenas uma amostra de encontros e será necessário fazer uma divisão treino e teste.
• Lembre de fazer um descritivo das variáveis antes, e de escrever o relatório de maneira que alguém que saiba sobre regressão mas não sabe nada sobre os dados entenda.

VARIÁVEIS

As variáveis do conjunto de dados bem como uma breve descrição sobre as mesmas seguem na relação abaixo. Os participantes de um encontro estão sendo chamados de p1 e p2.

• 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
• dec: “deu match”. Em outras palavras, tanto p1 quanto p2 gostariam de se encontrar novamente

De modo geral, os dados se comportam da seguinte forma:

skimr::skim(speed_dating)

Data summary

Name	speed_dating
Number of rows	4918
Number of columns	44
_______________________
Column type frequency:
character	3
factor	1
numeric	40
________________________
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
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	▇▁▅▅▅
gender	0	1.00	0.50	0.50	0.00	0.00	1.00	1.00	1.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	▂▂▅▃▇

No geral, tem-se 44 variáveis no conjunto de dados. Cada linha no conjunto de dados representa um encontro. Dessa forma, tem-se dados de 4918 encontros. O conjunto de dados é composto por 32 variáveis numéricas, 3 variáveis do tipo character, 4 variáveis do tipo factor e 5 variáveis lógicas.

Para o modelo, iremos utilizar as variáveis shar, intel, attr, fun, int_corr, same_race e prob.

MODELO

Treino (70%) e teste (30%) e criação do modelo:

set.seed(1)


speed_dating$id <- 1:nrow(speed_dating)

train <- speed_dating %>% sample_frac(0.70)
test  <- anti_join(speed_dating, train, by = 'id')

bm <- glm(dec ~ shar + intel + attr + fun + int_corr + samerace + prob, 
          data = train, 
          family = "binomial")

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

## # A tibble: 8 × 6
##   term        estimate std.error statistic conf.low conf.high
##   <chr>          <dbl>     <dbl>     <dbl>    <dbl>     <dbl>
## 1 (Intercept)  0.00288    0.303     -19.3   0.00157   0.00515
## 2 shar         1.26       0.0293      7.74  1.19      1.33   
## 3 intel        0.824      0.0375     -5.17  0.765     0.886  
## 4 attr         1.79       0.0345     16.9   1.67      1.92   
## 5 fun          1.18       0.0352      4.59  1.10      1.26   
## 6 int_corr     0.850      0.150      -1.08  0.634     1.14   
## 7 samerace     0.841      0.0938     -1.85  0.699     1.01   
## 8 prob         1.25       0.0255      8.66  1.19      1.31

pR2(bm)

## fitting null model for pseudo-r2

##           llh       llhNull            G2      McFadden          r2ML 
## -1437.5709515 -2002.4097274  1129.6775519     0.2820795     0.3197484 
##          r2CU 
##     0.4292794

O modelo é aproximadamente 28,2% explicativo em relação a amostra (Pseudo-R2 de McFadden). Esse valor é consideravelmente baixo.

Em relação aos termos, podemos observar que:

• shar, fun e prob possuem valores próximos nos coeficientes estimados, possuindo um efeito positivo;
• attr possui um efeito positivo bem maior comparado aos demais. Isso vai de encontro ao fator de que os encontros são rápidos e os candidatos não se conhecem previamente, fazendo com que a primeira impressão da aparência do outro candidato seja algo com impacto considerável, bem maior que fatores de personalidade;
• intel possui um efeito multiplicativo negativo (abaixo de 1), e pode, em certos casos, ter um efeito mínimo, por estar muito próximo de 1;
• não temos muita precisão em relação ao efeito de int_corr, podendo ter um efeito positivo, negativo ou até mesmo não ter efeito (intervalos de confiança maiores - dispersão);
• samerace segue o mesmo padrão, se houver efeito positivo é pequeno, e se houver negativo pode-se ter um maior impacto;

SOBRE O MODELO CRIADO

predictions = bm %>% 
  augment(type.predict = "response") %>% 
  mutate(predicted = .fitted > .5)

predictions$predicted <- factor(predictions$predicted, levels = c(TRUE, FALSE), labels = c('yes', 'no'))
predicted <- predictions$predicted

model_accuracy = sum((predicted == test$dec)) / NROW(predicted)

prediction <- predict(bm, test, type="response")
roc_object <- roc(test$dec, prediction)

## Setting levels: control = no, case = yes

## Setting direction: controls < cases

falso_positivo = sum((predicted == 'yes' & test$dec == 'no')) / NROW(predicted)

falso_negativo = sum((predicted == 'no' & test$dec == 'yes')) / NROW(predicted)

matriz_modelo = matrix(
  c(model_accuracy, auc(roc_object), falso_positivo, falso_negativo),
  nrow = 1,  
  ncol = 4,        
  byrow = TRUE         
)

rownames(matriz_modelo) = c('Modelo')
colnames(matriz_modelo) = c("Acurácia", "Área sob a curva", "Falsos positivos", "Falsos negativos")

print(matriz_modelo)

##         Acurácia Área sob a curva Falsos positivos Falsos negativos
## Modelo 0.5306958        0.8194813        0.2326057        0.2366985

As métricas apresentadas indicam uma performance razoável para baixa. Pode ser mais proveitoso analisar outro conjunto de variáveis para que o modelo seja mais representativo e preciso.