Logistična regresija
podatki <- read.table("/cloud/project/Poglavje 3/Zgled/Posojilo.csv", header=TRUE, sep=";", dec=",")
head(podatki)## ID Zamuda Starost Izobrazba Dohodek Obrok
## 1 1 0 45 1 28.3 1
## 2 2 0 30 1 20.1 1
## 3 3 0 44 1 36.0 1
## 4 4 0 47 1 184.7 1
## 5 5 0 52 1 59.4 1
## 6 6 0 28 1 25.3 1Opis spremenljivk
- Zamuda: Ali je pri vračanju posojila prišlo do zamude s plačili (0:NE, 1:DA)
- Starost: Starost v letih ob najemu posojila
- Izobrazba: Stopnja izobrazbe (1:Osnovna šola, 2:Srednja šola, 3:Fakulteta)
- Dohodek: Letni dohodek gospodinjstva v 1,000 €
- Obrok: Znesek mesečnega obroka kot % mesečne plače
podatki$ZamudaFaktor <- factor(podatki$Zamuda, #Kategorialna spremenljivka
levels = c(0, 1), #Vrednosti
labels = c("NE", "DA")) #Kategorije
podatki$IzobrazbaFaktor <- factor(podatki$Izobrazba,
levels = c(1, 2, 3),
labels = c("OŠ", "SŠ", "Fakulteta"))summary(podatki[ , c(-1, -2, -4)]) #Opisna statistika za izbrane spremenljivke## Starost Dohodek Obrok ZamudaFaktor
## Min. :20.00 Min. : 12.10 Min. : 1.000 NE:3744
## 1st Qu.:29.00 1st Qu.: 24.50 1st Qu.: 5.050 DA:1256
## Median :35.00 Median : 34.50 Median : 8.635
## Mean :35.39 Mean : 47.68 Mean :10.081
## 3rd Qu.:41.00 3rd Qu.: 54.73 3rd Qu.:13.682
## Max. :58.00 Max. :2461.70 Max. :44.620
## IzobrazbaFaktor
## OŠ :2699
## SŠ :1931
## Fakulteta: 370
##
##
## fit0 <- glm(ZamudaFaktor ~ 1, #Navedemo odvisno in pojasnjevalno spremenljivko. Če navedemo vrednost 1, pomeni, da v model vključimo samo regresijsko konstanto
family = binomial, #Binarna logistična regresija
data = podatki)
summary(fit0)##
## Call:
## glm(formula = ZamudaFaktor ~ 1, family = binomial, data = podatki)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -0.7606 -0.7606 -0.7606 1.6622 1.6622
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.09222 0.03261 -33.5 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 5636.5 on 4999 degrees of freedom
## Residual deviance: 5636.5 on 4999 degrees of freedom
## AIC: 5638.5
##
## Number of Fisher Scoring iterations: 4exp(cbind(obet = fit0$coefficients, confint.default(fit0))) #Obet za Y=1## obet 2.5 % 97.5 %
## (Intercept) 0.3354701 0.3147009 0.35761head(fitted(fit0)) #Napovedna verjetnost za Y=1## 1 2 3 4 5 6
## 0.2512 0.2512 0.2512 0.2512 0.2512 0.2512Psevdo_R2_fit0 <- 3744/5000 #Pravilo uvrščene enote
Psevdo_R2_fit0## [1] 0.7488fit1 <- glm(ZamudaFaktor ~ Starost,
family = binomial,
data = podatki)
summary(fit1)##
## Call:
## glm(formula = ZamudaFaktor ~ Starost, family = binomial, data = podatki)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.0682 -0.8089 -0.6619 1.2907 2.1983
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 0.882128 0.153646 5.741 9.4e-09 ***
## Starost -0.057229 0.004459 -12.834 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 5636.5 on 4999 degrees of freedom
## Residual deviance: 5459.6 on 4998 degrees of freedom
## AIC: 5463.6
##
## Number of Fisher Scoring iterations: 4anova(fit0, fit1, test="Chi") #Primerjava dveh modelov s pomočjo -2LL statistike## Analysis of Deviance Table
##
## Model 1: ZamudaFaktor ~ 1
## Model 2: ZamudaFaktor ~ Starost
## Resid. Df Resid. Dev Df Deviance Pr(>Chi)
## 1 4999 5636.5
## 2 4998 5459.6 1 176.94 < 2.2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1exp(cbind(RO = fit1$coefficients, confint.default(fit1))) #Razmerje obetov za Y=1## RO 2.5 % 97.5 %
## (Intercept) 2.4160349 1.7878016 3.2650294
## Starost 0.9443775 0.9361594 0.9526677fit2 <- glm(ZamudaFaktor ~ Starost + IzobrazbaFaktor + Dohodek + Obrok,
family = binomial,
data = podatki)
library(car)## Loading required package: carData##
## Attaching package: 'car'## The following object is masked from 'package:DescTools':
##
## Recodevif(fit2)## GVIF Df GVIF^(1/(2*Df))
## Starost 1.196017 1 1.093626
## IzobrazbaFaktor 1.037048 2 1.009136
## Dohodek 1.200523 1 1.095684
## Obrok 1.034195 1 1.016954podatki$StdOstanki <- rstandard(fit2)
podatki$Cook <- cooks.distance(fit2)
hist(podatki$StdOstanki,
main = "Histogram standardiziranih ostankov",
ylab = "Frekvenca",
xlab = "Standardizirani ostanki")
head(podatki[order(-podatki$Cook), c("ID", "Cook")]) #Izpišemo 6 enot z najvišjimi vrednostmi Cookove razdalje## ID Cook
## 4715 4715 0.156356823
## 1753 1753 0.006940358
## 1380 1380 0.004625247
## 2695 2695 0.004442882
## 4955 4955 0.003682399
## 31 31 0.003619914podatki1 <- podatki[-4715, ] #Odstranimo enoto ID 4715fit1 <- glm(ZamudaFaktor ~ Starost,
family = binomial,
data = podatki1)
fit2 <- glm(ZamudaFaktor ~ Starost + IzobrazbaFaktor + Dohodek + Obrok,
family = binomial,
data = podatki1)anova(fit1, fit2, test="Chi")## Analysis of Deviance Table
##
## Model 1: ZamudaFaktor ~ Starost
## Model 2: ZamudaFaktor ~ Starost + IzobrazbaFaktor + Dohodek + Obrok
## Resid. Df Resid. Dev Df Deviance Pr(>Chi)
## 1 4997 5455.4
## 2 4993 4670.2 4 785.19 < 2.2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(fit2)##
## Call:
## glm(formula = ZamudaFaktor ~ Starost + IzobrazbaFaktor + Dohodek +
## Obrok, family = binomial, data = podatki1)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.1801 -0.6977 -0.4876 0.3140 2.8650
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -0.6220921 0.1839839 -3.381 0.000722 ***
## Starost -0.0666204 0.0057555 -11.575 < 2e-16 ***
## IzobrazbaFaktorSŠ 0.4772653 0.0778950 6.127 8.95e-10 ***
## IzobrazbaFaktorFakulteta 1.0110783 0.1321927 7.649 2.03e-14 ***
## Dohodek -0.0003269 0.0012649 -0.258 0.796037
## Obrok 0.1391631 0.0057219 24.321 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 5633.7 on 4998 degrees of freedom
## Residual deviance: 4670.2 on 4993 degrees of freedom
## AIC: 4682.2
##
## Number of Fisher Scoring iterations: 5exp(cbind(RO = fit2$coefficients, confint.default(fit2)))## RO 2.5 % 97.5 %
## (Intercept) 0.5368202 0.3743014 0.7699034
## Starost 0.9355503 0.9250561 0.9461635
## IzobrazbaFaktorSŠ 1.6116609 1.3834687 1.8774916
## IzobrazbaFaktorFakulteta 2.7485631 2.1212070 3.5614625
## Dohodek 0.9996731 0.9971979 1.0021545
## Obrok 1.1493115 1.1364944 1.1622732podatki1$OceneVerjet <- fitted(fit2)
head(podatki1)## ID Zamuda Starost Izobrazba Dohodek Obrok ZamudaFaktor
## 1 1 0 45 1 28.3 1 NE
## 2 2 0 30 1 20.1 1 NE
## 3 3 0 44 1 36.0 1 NE
## 4 4 0 47 1 184.7 1 NE
## 5 5 0 52 1 59.4 1 NE
## 6 6 0 28 1 25.3 1 NE
## IzobrazbaFaktor StdOstanki Cook OceneVerjet
## 1 OŠ -0.2417247 1.715122e-06 0.02959529
## 2 OŠ -0.3979768 6.723101e-06 0.07669583
## 3 OŠ -0.2504382 1.802526e-06 0.03149286
## 4 OŠ -0.2340714 2.585137e-06 0.02473543
## 5 OŠ -0.1921314 9.924314e-07 0.01858559
## 6 OŠ -0.4254515 8.908351e-06 0.08654490#Če je ocenjena verjetnost pod 0,50, potem je oseba uvrščena v razred NE, drugače DA
podatki1$Uvrstitev <- ifelse(test = podatki1$OceneVerjet < 0.50,
yes = "NE",
no = "DA")
podatki1$UvrstitevFaktor <- factor(podatki1$Uvrstitev,
levels = c("NE", "DA"),
labels = c("NE", "DA"))
razvrst_tabela <- table(podatki1$ZamudaFaktor, podatki1$UvrstitevFaktor) #Naredimo razvrstitveno tabelo iz dveh faktorjev
razvrst_tabela##
## NE DA
## NE 3532 212
## DA 871 384uvrstitev_fit2 <- (razvrst_tabela[1,1] + razvrst_tabela[2,2] )/ nrow(podatki1) #Enote po glavni diagonali so uvrščene pravilno
uvrstitev_fit2## [1] 0.7833567library(ggplot2)
ggplot(podatki1, aes(x=OceneVerjet, fill=ZamudaFaktor))+
theme_linedraw() +
geom_histogram(position="fill", binwidth=0.1) +
scale_fill_grey() +
geom_vline(xintercept=0.50) +
labs(fill="Zamuda") +
ylab("Delež")
qchisq(p = 0.001,
df = 1,
lower.tail = FALSE)## [1] 10.82757