Regressao_Logistica_FPCC2
2022-06-12
Exercício de Regressão Logística - Lab 4p3 de FPCC2
Pergunta:
| 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. |
O processo inicia lendo o conjunto de dados:
dados <- read.csv("speed-dating2.csv")Listar nomes das colunas:
colnames(dados)## [1] "iid" "gender" "order" "pid" "int_corr" "samerace"
## [7] "age_o" "age" "field" "race" "from" "career"
## [13] "sports" "tvsports" "exercise" "dining" "museums" "art"
## [19] "hiking" "gaming" "clubbing" "reading" "tv" "theater"
## [25] "movies" "concerts" "music" "shopping" "yoga" "attr"
## [31] "sinc" "intel" "fun" "amb" "shar" "like"
## [37] "prob" "match_es" "attr3_s" "sinc3_s" "intel3_s" "fun3_s"
## [43] "amb3_s" "dec"Visualizar o boxplot de algumas variáveis independentes para entender comportamento dos dados:
p0 <- ggplot(dados, aes(order, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p1 <- ggplot(dados, aes(age, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p2 <- ggplot(dados, aes(age_o, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p3 <- ggplot(dados, aes(exercise, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p4 <- ggplot(dados, aes(attr, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p5 <- ggplot(dados, aes(attr3_s, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p6 <- ggplot(dados, aes(sinc, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p7 <- ggplot(dados, aes(sinc3_s, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p8 <- ggplot(dados, aes(intel, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p9 <- ggplot(dados, aes(intel3_s, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p10 <- ggplot(dados, aes(fun, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p11 <- ggplot(dados, aes(fun3_s, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p12 <- ggplot(dados, aes(shar, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p13 <- ggplot(dados, aes(like, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
p14 <- ggplot(dados, aes(prob, dec)) + geom_boxplot(outlier.colour = "red", outlier.shape = 1, fill = "white", colour = "#3366FF")
plot_grid(p0, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14,
ncol = 3, nrow= 5,
labels = c('order', 'age', 'age_o', 'exercise', 'attr', 'attr3_s',
'sinc', 'sinc3_s', 'intel', 'intel3_s', 'fun', 'fun3_s', 'shar', 'like', 'prob'),
label_y = 1.07, label_x = 0.1, label_size = 8) 
Após visualizar o boxplot de algumas variáveis independentes, foi observado que há muita semelhança na distribuição de algumas delas em relação a variável dependente (dec), assim, foram selecionadas sete variáveis independentes com (aparente) boa capacidade descritiva: like, prob, shar, order, gender, attr e intel.
Gerar nova base de dados com variáveis selecionadas:
dados_select <- dados %>%
select(dec, gender, like, attr, prob, shar, order, intel) %>%
na.omit() %>%
mutate(dec_int = case_when(.$dec == "no" ~ 0,
.$dec == "yes" ~ 1)) Observando as correlações entre as variáveis.
ggpairs(dados_select)
Com a nova base de dados obtida, foi realizado o particionamento da mesma em treino e teste. Foi adotada a pseudo-aleatoriedade para garantir que os resultados sejam reproduzíveis. Nessa abordagem foi usado o valor de semente igual à 42. O particionamento foi realizando considerando 80% para treinamento e 20% para testes
set.seed(42) # usar a pseudo aleatoriedade para garantir que os resultados sejam reproduzíveis. Foi adotado o valor 42 para semente
sub_amostras <- sample( 1:length(dados_select$dec_int) , (length(dados_select$dec_int)*.80) ) #selecionar 80% das amostras
treino = dados_select[sub_amostras,]
testes = dados_select[-sub_amostras,]
sprintf("número de amostras: treino = %d e testes = %d", length(treino$dec), length(testes$dec))## [1] "número de amostras: treino = 3380 e testes = 846"Criação do modelo com função logística:
modelo <- glm(dec_int ~ gender + like + attr + prob + shar + order + intel,
data = treino,
family = "binomial")
summary(modelo)##
## Call:
## glm(formula = dec_int ~ gender + like + attr + prob + shar +
## order + intel, family = "binomial", data = treino)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.9335 -0.7665 -0.2269 0.7709 3.3559
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -6.436581 0.317189 -20.293 < 2e-16 ***
## gender 0.346284 0.088382 3.918 8.93e-05 ***
## like 0.582284 0.045317 12.849 < 2e-16 ***
## attr 0.412660 0.033559 12.296 < 2e-16 ***
## prob 0.148617 0.024485 6.070 1.28e-09 ***
## shar 0.147110 0.028223 5.212 1.86e-07 ***
## order -0.008662 0.007788 -1.112 0.266
## intel -0.241471 0.036071 -6.694 2.17e-11 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 4615.6 on 3379 degrees of freedom
## Residual deviance: 3176.9 on 3372 degrees of freedom
## AIC: 3192.9
##
## Number of Fisher Scoring iterations: 5Conforme o que foi apresentado no resultado de treinamento, de acordo com o valor Z (teste de Wald), as variáveis significativas são: gender, like, att, prob, shar e intel. Assim, a variável order será desconsiderada e o modelo será treinado novamente.
modelo <- glm(dec_int ~ gender + like + attr + prob + shar + intel,
data = treino,
family = "binomial")
summary(modelo)##
## Call:
## glm(formula = dec_int ~ gender + like + attr + prob + shar +
## intel, family = "binomial", data = treino)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.9484 -0.7673 -0.2265 0.7792 3.3513
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -6.53962 0.30402 -21.510 < 2e-16 ***
## gender 0.34729 0.08835 3.931 8.47e-05 ***
## like 0.58346 0.04529 12.884 < 2e-16 ***
## attr 0.41256 0.03354 12.299 < 2e-16 ***
## prob 0.15100 0.02438 6.193 5.91e-10 ***
## shar 0.14425 0.02807 5.138 2.77e-07 ***
## intel -0.23870 0.03594 -6.641 3.11e-11 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 4615.6 on 3379 degrees of freedom
## Residual deviance: 3178.1 on 3373 degrees of freedom
## AIC: 3192.1
##
## Number of Fisher Scoring iterations: 5Uma vez que estamos trabalhando com funções logísticas, para compreender melhor os coeficientes, vamos verificar os coeficientes de acordo com a aplicação da função exponencial:
exp(modelo$coefficients)## (Intercept) gender like attr prob shar
## 0.001445043 1.415232578 1.792232003 1.510680845 1.163000747 1.155177243
## intel
## 0.787652351Assim é possível observar que a variável like é a mais significativa no conjunto utilizado. Para cada para ponto a mais na escala de 0 a 10 de quanto a pessoa 1 gostou da pessoa 2, aumenta em 1.65 vezes as chances de dar match. A segunda variável mais significativa é attr, que a cada ponto na escala aumenta em 1.53 vezes essas chances. Em contaponto, observamos que a variável intel, que corresponde a inteligência, diminui as chances de ocorrer um match pois cada unidade será multiplicado pelo valor de 0.78.
Essa percepção é reforçada e/ou melhor ilustrada no gráfico abaixo.
tidy(modelo, conf.int = TRUE, exponentiate = TRUE) %>%
filter(term != "(Intercept)") %>%
ggplot(aes(x=term, y=estimate, ymin = conf.low, ymax = conf.high)) +
geom_point() +
geom_linerange()
Agora, após novo treinamento, o conjunto de testes é submetido ao modelo:
result = augment(modelo,
newdata = testes,
type.predict = "response")Os gráficos abaixo mostram os resultados obtidos em relação aos valores esperados. Inicialmente temos um gráfico segmentado de acordo com o gênero, 0 para feminino e 1 para masculino, no qual é possível verificar se o modelo possui discrepâncias na predição entre estas classes, o que enão ocorre.
O segundo gráfico mostra a mesma informação mas para o conjunto completo, sem segmentação de gênero. As nuvens de pontos acompanham a curva da regressão em ambos gráficos e tem maior concentração nas extremidades.
ggplot(result, aes(x=.fitted, y=dec_int))+
geom_point(alpha = .1) +
stat_smooth(method="glm", se = FALSE, method.args = list(family=binomial), col="red", lty=2)+
facet_grid(.~reorder(gender, .fitted))## `geom_smooth()` using formula 'y ~ x'
ggplot(result, aes(x=.fitted, y=dec_int))+
geom_point(alpha = .1) +
stat_smooth(method="glm", method.args = list(family=binomial), col="red", lty=1)## `geom_smooth()` using formula 'y ~ x'
Para além da percepção visual, quantitativamente é possível avaliar também o modelo de acordo com sua acurácia, que se calcula dividindo a soma dos valores verdadeiros positivos e verdadeiros negativos pelo total de predições, conforme equação abaixo.
\(\frac{(VP + VN)} {(VP + VN + FP + FN)}\)
y_pred = ifelse(result$.fitted > 0.5, 1, 0)
cm1 <- table(result$dec_int, y_pred)
cm1 # MATRIZ DE CONFUSÃO PARA OBTER ACURÁCIA## y_pred
## 0 1
## 0 402 94
## 1 105 245acc = (cm1[1,1]+cm1[2,2])/sum(cm1)
sprintf("Acurácia obtida pelo modelo em termos percentuais: %d ", round(acc*100))## [1] "Acurácia obtida pelo modelo em termos percentuais: 76 "#sprintf("número de amostras: treino = %d e testes = %d", length(treino$dec), length(testes$dec))