Lab 06 - Regressão Logística - Speed Dating
Diego-Kazadi
2023-06-30
Breve Descrição da Atividade
Speed Dating (encontro relâmpago)
A partir do acesso ao repositório base do laboratório vocês irão criar um novo repositório privado no github classroom, que ficará hospedado na organização da disciplina. O repositório base contém dados de encontros relâmpago (speed-dating), descritos e disponíveis em “5-regressao/speed-dating”. Especialmente, observe para uma coluna chamada ‘dec’ dos dados (speed-dating2.csv), que diz se houve match entre os dois participantes do encontro (ambos disseram que gostariam de se encontrar novamente depois). O lab deve ser respondido a partir de artefatos de código para a análise (R, R Markdown, Python, Jupyter e/ou Colab).
“Temos um conjunto de dados contendo informações de 5000 encontros relâmpagos (speed dating) que ocorreram em eventos de matchmaking. Esses encontros envolveram 310 jovens americanos. Os dados foram coletados por professores da Columbia Business School durante um experimento específico. No experimento, os participantes foram convidados a participar de eventos de encontros relâmpagos, onde tinham vários encontros de 4 minutos por noite. Após cada encontro, os participantes preenchiam fichas de avaliação, fornecendo suas impressões e opiniões sobre as pessoas com quem se encontraram.
Cada linha nos dados representa um desses encontros específicos, contendo informações sobre os dois participantes envolvidos, suas características, preferências, avaliações mútuas e a indicação de se houve um “match” (quando ambos os participantes expressaram interesse em se encontrar novamente).”
Exploração de dados
Leitura de dados
data_speed <- read_csv("5-regressao/speed-dating/speed-dating2.csv")## Rows: 4918 Columns: 44
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (4): field, from, career, dec
## dbl (40): iid, gender, order, pid, int_corr, samerace, age_o, age, race, spo...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.head(data_speed, 5)## # A tibble: 5 × 44
## iid gender order pid int_corr samerace age_o age field race from
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <chr> <dbl> <chr>
## 1 1 0 4 11 0.14 0 27 21 Law 4 Chicago
## 2 1 0 3 12 0.54 0 22 21 Law 4 Chicago
## 3 1 0 10 13 0.16 1 22 21 Law 4 Chicago
## 4 1 0 5 14 0.61 0 23 21 Law 4 Chicago
## 5 1 0 7 15 0.21 0 24 21 Law 4 Chicago
## # ℹ 33 more variables: career <chr>, sports <dbl>, tvsports <dbl>,
## # exercise <dbl>, dining <dbl>, museums <dbl>, art <dbl>, hiking <dbl>,
## # gaming <dbl>, clubbing <dbl>, reading <dbl>, tv <dbl>, theater <dbl>,
## # movies <dbl>, concerts <dbl>, music <dbl>, shopping <dbl>, yoga <dbl>,
## # attr <dbl>, sinc <dbl>, intel <dbl>, fun <dbl>, amb <dbl>, shar <dbl>,
## # like <dbl>, prob <dbl>, match_es <dbl>, attr3_s <dbl>, sinc3_s <dbl>,
## # intel3_s <dbl>, fun3_s <dbl>, amb3_s <dbl>, dec <chr>Visualizar as variaveis relevantes
data_speed <- read_csv("5-regressao/speed-dating/speed-dating2.csv")## Rows: 4918 Columns: 44
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (4): field, from, career, dec
## dbl (40): iid, gender, order, pid, int_corr, samerace, age_o, age, race, spo...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.selected_vars <- select(data_speed, dec, age, attr, gender, samerace)
glimpse(selected_vars)## Rows: 4,918
## Columns: 5
## $ dec <chr> "yes", "yes", "yes", "yes", "yes", "no", "yes", "no", "yes", …
## $ age <dbl> 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 24, 24, 24, 24, 24, 2…
## $ attr <dbl> 6, 7, 5, 7, 5, 4, 7, 4, 7, 5, 5, 8, 5, 7, 6, 8, 7, 5, 7, 6, 7…
## $ gender <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ samerace <dbl> 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1…Com base nos resultados exibidos, podemos interpretar as seguintes informações das variáveis selecionadas:
Variável “dec” (decisão): É uma variável categórica com os valores “yes” e “no”. Representa a decisão dos participantes em relação a um novo encontro caso sejo yes e o valor no caso não terá um novo encontro.
Variável “age” (idade): É uma variável numérica contínua que representa a idade dos participantes.
Variável “attr” (atratividade): É uma variável numérica contínua que representa a atratividade dos participantes. O valor varia de 1 a 10, sendo 1 menos atraente e 10 muito atraente.
Variável “gender” (gênero): É uma variável numérica binária que representa o gênero dos participantes. O valor 0 pode representar o gênero feminino e o valor 1 pode representar o gênero masculino, mas sem informações adicionais não é possível afirmar com certeza.
Variável “samerace” (mesma raça): É uma variável numérica binária que indica se o participante tem a mesma raça que o parceiro. O valor 0 pode representar que não têm a mesma raça, e o valor 1 pode representar que têm a mesma raça.
Descricao das variaveis
- 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
data_speed <- read_csv("5-regressao/speed-dating/speed-dating2.csv")## Rows: 4918 Columns: 44
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (4): field, from, career, dec
## dbl (40): iid, gender, order, pid, int_corr, samerace, age_o, age, race, spo...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.# Converter os valores de gender para texto
data_speed$gender <- ifelse(data_speed$gender == 0, "feminino", "masculino")
ggplot(data_speed, aes(x = gender, fill = gender)) +
geom_bar() +
scale_fill_manual(values = c("feminino" = "pink", "masculino" = "lightblue")) +
ggtitle("Grafico de barras para a variavel 'gender'") +
xlab("Sexo") +
ylab("Contagem")
data_speed <- read_csv("5-regressao/speed-dating/speed-dating2.csv")## Rows: 4918 Columns: 44
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (4): field, from, career, dec
## dbl (40): iid, gender, order, pid, int_corr, samerace, age_o, age, race, spo...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.data_speed$gender <- factor(data_speed$gender, levels = c(0, 1), labels = c("feminino", "masculino"))
ggplot(data_speed, aes(x = age)) +
geom_histogram(binwidth = 1, fill = "skyblue", alpha = 0.75) +
facet_wrap(~gender) +
ggtitle("Histograma da idade dos participantes por genero") +
xlab("Idade") +
ylab("Frequencia")## Warning: Removed 52 rows containing non-finite values (`stat_bin()`).
Ao observar o histograma da idade dos participantes separado por gênero,
podemos fazer as seguintes interpretações:
Frequência: A altura das barras representa a frequência dos participantes em cada faixa de idade. Quanto mais alta a barra, maior é o número de participantes naquela faixa de idade.
Faixa de idade: A faixa de idade mais frequente para ambos os gêneros está entre 20 e 30 anos. Isso indica que a maioria dos participantes, tanto femininos quanto masculinos, se encontra nessa faixa etária.
Distribuição por gênero: Podemos observar que a distribuição dos participantes por gênero varia. No painel “feminino”, a frequência é maior nas faixas de idade entre 20 e 25 anos, com uma diminuição gradual à medida que a idade aumenta. No painel “masculino”, a frequência é mais uniforme nas faixas de idade entre 20 e 30 anos.
Divisão de dados
Para dividir os dados em conjuntos de treinamento e teste, utilizamos a função createDataPartition do pacote caret. A função createDataPartition realiza uma divisão aleatória preservando a proporção das classes. Aqui está a divisão com uma proporção de 70% para treinamento e 30% para teste:
# Carregar o pacote caret
library(caret)## Carregando pacotes exigidos: lattice##
## Attaching package: 'caret'## The following object is masked from 'package:purrr':
##
## lift# Definir a proporção de divisão
proporcao_treino <- 0.7
# Gerar o índice para a divisão dos dados
set.seed(123) # Definir uma semente para reprodução dos resultados
indices_divisao <- createDataPartition(data_speed$dec, times = 1, p = proporcao_treino)
# Dividir os dados em treinamento e teste
dados_treino <- data_speed[indices_divisao$Resample1, ]
dados_teste <- data_speed[-indices_divisao$Resample1, ]Os dados divididos em dados_treino (70% dos dados originais) e dados_teste (30% dos dados originais), respeitando a proporção da variável dec que indica se houve encontro ou não.
Construção Modelo Regressão Logistica
# Certifique-se de que os valores da variável "dec" sejam "yes" e "no"
dados_treino$dec <- factor(dados_treino$dec, levels = c("yes", "no"))
# Ajuste o modelo de regressão logística
modelo <- glm(dec ~ fun + shar + like + attr + sinc,
data = dados_treino,
family = binomial())
# Obtenha as estatísticas do modelo
stats <- tidy(modelo, conf.int = TRUE, exponentiate = TRUE)
stats## # A tibble: 6 × 7
## term estimate std.error statistic p.value conf.low conf.high
## <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 (Intercept) 463. 0.286 21.5 2.37e-102 267. 818.
## 2 fun 0.918 0.0374 -2.27 2.29e- 2 0.854 0.988
## 3 shar 0.861 0.0300 -4.98 6.35e- 7 0.812 0.913
## 4 like 0.543 0.0489 -12.5 6.76e- 36 0.492 0.596
## 5 attr 0.671 0.0357 -11.2 5.93e- 29 0.625 0.719
## 6 sinc 1.30 0.0350 7.50 6.37e- 14 1.21 1.39Os resultados para cada variável:
Intercept: O intercepto do modelo indica o log-odds da resposta “dec” para um participante com todos os outros preditores igual a zero. Neste caso, o valor estimado é 462.6825413, indicando um alto log-odds inicial.
fun: A variável “fun” tem uma estimativa de coeficiente de 0.9184724, com um erro padrão de 0.03738584. O valor p associado é 0.02292092, indicando que essa variável é estatisticamente significativa no modelo. Para cada aumento unitário em “fun”, o log-odds da resposta “dec” é multiplicado por 0.9184724.
shar: A variável “shar” tem uma estimativa de coeficiente de 0.8612815, com um erro padrão de 0.02998450. O valor p associado é 6.34625e-07, indicando que essa variável é estatisticamente significativa no modelo. Para cada aumento unitário em “shar”, o log-odds da resposta “dec” é multiplicado por 0.8612815.
like: A variável “like” tem uma estimativa de coeficiente de 0.5425329, com um erro padrão de 0.04888992. O valor p associado é 6.764972e-36, indicando que essa variável é altamente significativa no modelo. Para cada aumento unitário em “like”, o log-odds da resposta “dec” é multiplicado por 0.5425329.
attr: A variável “attr” tem uma estimativa de coeficiente de 0.6711319, com um erro padrão de 0.03571225. O valor p associado é 5.931569e-29, indicando que essa variável é altamente significativa no modelo. Para cada aumento unitário em “attr”, o log-odds da resposta “dec” é multiplicado por 0.6711319.
sinc: A variável “sinc” tem uma estimativa de coeficiente de 1.3006249, com um erro padrão de 0.03504508. O valor p associado é 6.372366e-14, indicando que essa variável é altamente significativa no modelo. Para cada aumento unitário em “sinc”, o log-odds da resposta “dec” é multiplicado por 1.3006249.
- Resumo e interpretados em termos de odds ratiosque representam a mudança na razão de chances da resposta “dec” para cada unidade de aumento nas variáveis independentes.
Os resultados do modelo de regressão logística indicam que, para cada unidade de aumento na variável “fun”, as chances de a resposta “dec” ser afirmativa aumentam em aproximadamente 91,8%, mantendo as demais variáveis constantes. Da mesma forma, um aumento de uma unidade na variável “shar” está associado a um aumento de cerca de 86,1% nas chances de resposta positiva. Além disso, observa-se que um aumento de uma unidade nas variáveis “like”, “attr” e “sinc” está relacionado a um aumento nas chances de resposta afirmativa de aproximadamente 54,3%, 67,1% e 130,1%, respectivamente, com as demais variáveis mantidas constantes. Esses resultados destacam a importância dessas variáveis na predição da resposta “dec” e fornecem insights sobre como elas influenciam as chances de um encontro ocorrer.
Análise de Modelo de treino
Calcular as métricas de pseudo R2 para o modelo ajustado aos dados de treinamento
# Ajustar o modelo aos dados de treinamento
modelo <- glm(dec ~ fun + shar + like + attr + sinc,
data = dados_treino,
family = binomial())
# Calcular as métricas de pseudo R2 para o modelo
pseudo_r2 <- pR2(modelo, method = c("nagelkerke", "coxsnell"))## fitting null model for pseudo-r2# Exibir as métricas de pseudo R2
pseudo_r2## llh llhNull G2 McFadden r2ML
## -1412.6450060 -2014.3111576 1203.3323033 0.2986957 0.3345016
## r2CU
## 0.4494836Os resultados das métricas de pseudo R2 para o modelo ajustado aos dados de treinamento são os seguintes:
Pseudo R2 de McFadden: 0.2986957 Pseudo R2 de Cox-Snell: 0.3345016 Pseudo R2 de Nagelkerke: 0.4494836
Essas métricas fornecem uma medida de ajuste do modelo aos dados, em comparação com um modelo nulo (modelo sem variáveis independentes). Quanto mais próximo de 1, maior é o ajuste do modelo. No caso, os valores obtidos indicam que o modelo possui um ajuste moderado aos dados de treinamento.
Executar dados teste
# Aplicar o modelo ajustado nos dados de teste
predicoes_teste <- predict(modelo, newdata = dados_teste, type = "response")
previsoes <- data.frame(segundo_modelo = predicoes_teste > 0.5,
segundo_dados = dados_teste$dec == "yes")
# Tabela de contagem
tabela <- table(previsoes$segundo_modelo, previsoes$segundo_dados)
tabela##
## FALSE TRUE
## FALSE 119 386
## TRUE 609 161A tabela cruzada entre as variáveis “segundo_modelo” e “segundo_dados”, podemos analisar a concordância e discordância entre as previsões do modelo e os valores reais dos dados de teste.
A categoria “FALSE” em “segundo_modelo” representa as previsões do modelo que indicaram uma resposta negativa ou não favorável. Nesse caso, temos 119 observações em que o modelo previu uma resposta negativa e os dados de teste também apresentaram uma resposta negativa.
A categoria “TRUE” em “segundo_modelo” representa as previsões do modelo que indicaram uma resposta positiva ou favorável. Nesse caso, temos 609 observações em que o modelo previu uma resposta positiva.
A categoria “FALSE” em “segundo_dados” representa os valores reais dos dados de teste que indicaram uma resposta negativa. Nesse caso, temos 386 observações em que os dados de teste apresentaram uma resposta negativa.
A categoria “TRUE” em “segundo_dados” representa os valores reais dos dados de teste que indicaram uma resposta positiva. Nesse caso, temos 161 observações em que os dados de teste apresentaram uma resposta positiva.
Aplicar as métricas de avaliação
Começaremos com a acurácia
# Calcular acurácia
acuracia <- (tabela[1, 1] + tabela[2, 2]) / sum(tabela)
cat("Acurácia:", acuracia, "\n")## Acurácia: 0.2196078A acurácia mede a proporção de predições corretas em relação ao total de predições. Quanto maior a acurácia, melhor o desempenho do modelo.
O resultado da acurácia foi 0.2196078, isso significa que o modelo obteve uma taxa de acerto de aproximadamente 21.96%. Em outras palavras, apenas cerca de 21.96% das predições feitas pelo modelo estão corretas em relação às classes reais dos dados de teste.
Em seguida, vamos calcular a precisão:
# Calcular precisão
precisao <- tabela[2, 2] / sum(tabela[, 2])
cat("Precisão:", precisao, "\n")## Precisão: 0.2943327O resultado da precisão foi 0.2943327, isso significa que o modelo obteve uma taxa de precisão de aproximadamente 29.43%. Em outras palavras, quando o modelo previu a classe “yes” (positivo), ele acertou cerca de 29.43% das vezes.
Em seguida, vamos calcular o recall:
# Calcular recall (taxa de verdadeiros positivos)
recall <- tabela[2, 2] / sum(tabela[2, ])
cat("Recall:", recall, "\n")## Recall: 0.2090909O resultado do recall foi 0.2090909, isso significa que o modelo obteve uma taxa de recall de aproximadamente 20.91%. Em outras palavras, o modelo foi capaz de identificar corretamente cerca de 20.91% dos casos verdadeiramente positivos.
Por último, vamos calcular a área sob a curva ROC (AUC-ROC):
# Calcular a área sob a curva ROC (AUC-ROC)
library(pROC)## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, varauc_roc <- roc(as.numeric(previsoes$segundo_dados) - 1, as.numeric(previsoes$segundo_modelo) - 1)$auc## Setting levels: control = -1, case = 0## Setting direction: controls > casescat("AUC-ROC:", auc_roc, "\n")## AUC-ROC: 0.7711029O valor de 0.7711029 que é maais perto de 1 sugere que o modelo apresenta uma boa capacidade de distinguir entre as classes positiva e negativa, sendo melhor do que um modelo aleatório.
Concluir:
Com base na avaliação do modelo, obtivemos os seguintes resultados das métricas de desempenho. A acurácia do modelo foi de 0.2196078, o que significa que apenas 21.96% das previsões foram corretas. A precisão do modelo foi de 0.2943327, indicando que apenas 29.43% das previsões positivas foram realmente corretas. O recall, que mede a taxa de verdadeiros positivos, foi de 0.2090909, ou seja, apenas 20.91% dos casos positivos foram corretamente identificados. Por fim, a AUC-ROC foi de 0.7711029, indicando que o modelo possui uma capacidade razoável de distinguir entre as classes positiva e negativa. Em resumo, o modelo apresentou um desempenho geralmente baixo, com acurácia, precisão e recall abaixo de 30%, enquanto a AUC-ROC indicou uma capacidade moderada de discriminação entre as classes.
No entanto, as demais métricas, como acurácia, precisão e recall, são baixas, indicando que o modelo tem dificuldade em identificar corretamente os casos em que não há reencontro de participantes. Isso sugere a presença de um viés no modelo, favorecendo a classificação de encontros positivos em detrimento dos negativos.