GLM
Nagy Balázs Gábor
2024-11-29
TSM beadandó GLM része
Ebben a dokumentumban egy autóvezetők adatait tartalmazó adatbázison belül a gyorshajtások számát fogom a többi változó segítségével magyarázni. Mivel a gyorshajtások száma valószínűleg egy Poisson eloszlást (vagy ahhoz hasonlót) követ, ezért GLM-et használok.
Adat forrása: https://www.kaggle.com/datasets/sagnik1511/car-insurance-data
Adatok beolvasása, átalakítása
df <- read.csv("~/Car_Insurance_Claim.csv")
# változók faktorizációja
fact_cols <- c("AGE","GENDER","RACE","DRIVING_EXPERIENCE","EDUCATION",
"INCOME","VEHICLE_OWNERSHIP","VEHICLE_YEAR","MARRIED","CHILDREN",
"POSTAL_CODE","VEHICLE_TYPE")
df[, fact_cols] <- lapply(df[, fact_cols], as.factor)
# felesleges változók kiszűrése
df <- df[,!(colnames(df) %in% c("ID","DUIS","PAST_ACCIDENTS","OUTCOME",
"DRIVING_EXPERIENCE"))]
# életkor faktort az adott életkorintervallum közepével helyettesítjük,
# 65+-ra 70-et választottam. Ez azért kell, hogy lehessen offsetet alkalmazni.
df$AGE <- c(20,33,52,70)[(df$AGE |> as.numeric())]Gyorshajtások száma
Ahogyan láthatjuk, az emberek nagyrésze nem gyorshajt, azonban vannak
olyanok akik több, mint 20-szor is gyorshajtottak.
Modellek
A gyorsulások számát gamma, poisson és negatív binomiális GLM modellekkel fogom elemezni, majd ezeket kiértékelem, és kiválasztom a legjobbat, ami alapján elemzem az eredményt.
library(glmnet)## A szükséges csomag betöltődik: Matrix## Loaded glmnet 4.1-8library(fastDummies)
library(MASS)
library(statmod)
m.nb <- glm.nb(SPEEDING_VIOLATIONS ~ . - AGE + offset(log(AGE)) - ANNUAL_MILEAGE + log(ANNUAL_MILEAGE), link = "log", data = df)
m.po <- glm(SPEEDING_VIOLATIONS ~ . -AGE + offset(log(AGE))- ANNUAL_MILEAGE + log(ANNUAL_MILEAGE), family = poisson(), data = df)
m.ga <- glm(I(SPEEDING_VIOLATIONS+0.01) ~ . -AGE + offset(log(AGE))- ANNUAL_MILEAGE + log(ANNUAL_MILEAGE), family = Gamma(link = "log") , data = df)
matrix(c(m.nb$aic,m.po$aic,m.ga$aic), dimnames = list(c("Neg.Binom","Poisson","Gamma")))## [,1]
## Neg.Binom 23252.626
## Poisson 24952.681
## Gamma 6780.657AIC alapján a gamma modell a legjobb, azonban még a maradéktagokat elsőnek meg kell nézni, hogy az eloszlásuk megfelelő-e.
plot(density(qresid(m.ga)), col='blue')
lines(density(qresid(m.po)), col='red')
lines(density(qresid(m.nb)), col='green')
Az ábrán a kék a gamma, zöld a negatív binomiális és a piros a poisson.
Itt az eloszlásnak normálishoz hasonlónak kell lennie, nem olyannak mint a gamma (kék) eloszlás, így azt elvethetjük, a maradéktagok nem véletlenek.
Így a második legkisebb AIC mutatóval rendelkező modellt választjuk véglegesnek.
Modell együtthatói és elemzése
summary(m.nb)##
## Call:
## glm.nb(formula = SPEEDING_VIOLATIONS ~ . - AGE + offset(log(AGE)) -
## ANNUAL_MILEAGE + log(ANNUAL_MILEAGE), data = df, link = "log",
## init.theta = 1.673737154)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 1.236405 0.611356 2.022 0.04314 *
## GENDERmale 0.625655 0.028126 22.245 < 2e-16 ***
## RACEminority -0.010121 0.046140 -0.219 0.82637
## EDUCATIONnone 0.087328 0.045645 1.913 0.05572 .
## EDUCATIONuniversity -0.090304 0.031450 -2.871 0.00409 **
## INCOMEpoverty -0.651055 0.067411 -9.658 < 2e-16 ***
## INCOMEupper class 0.100228 0.039937 2.510 0.01208 *
## INCOMEworking class -0.278159 0.051997 -5.350 8.82e-08 ***
## CREDIT_SCORE 0.097834 0.151074 0.648 0.51725
## VEHICLE_OWNERSHIP1 0.012084 0.034802 0.347 0.72843
## VEHICLE_YEARbefore 2015 -0.002656 0.029940 -0.089 0.92931
## MARRIED1 0.092862 0.032603 2.848 0.00440 **
## CHILDREN1 0.279997 0.037209 7.525 5.27e-14 ***
## POSTAL_CODE21217 0.036785 0.128814 0.286 0.77521
## POSTAL_CODE32765 0.703038 0.032476 21.648 < 2e-16 ***
## POSTAL_CODE92101 0.025977 0.067896 0.383 0.70202
## VEHICLE_TYPEsports car 0.010709 0.064190 0.167 0.86750
## log(ANNUAL_MILEAGE) -0.597034 0.063122 -9.458 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for Negative Binomial(1.6737) family taken to be 1)
##
## Null deviance: 10252.8 on 8148 degrees of freedom
## Residual deviance: 8045.1 on 8131 degrees of freedom
## (1851 observations deleted due to missingness)
## AIC: 23253
##
## Number of Fisher Scoring iterations: 1
##
##
## Theta: 1.6737
## Std. Err.: 0.0726
##
## 2 x log-likelihood: -23214.6260Szignifikáns változók
Ahogyan láthatjuk a férfiaknak szignifikánsan magasabb a gyorshajtásaik várható értéke, mint a nőké. Emellett szignifikánsak az oktatottsági szint változói is. A középiskolát végzettekhez képest mind az egyetemet, mind a csak általánosiskolát végzettek kevesebbet gyorshajtanak. Továbbá a középosztályhoz képest, az alacsonyabb keresetűek szignifikánsan kevesebbszer, míg a felsőosztály tagjai szignifikánsan többet gyorshajtanak. Mindezek mellett az adott sofőr családi állapota is hatással van a gyorshajtások számára, a házasok és a gyerekesek is többször hajtanak gyorsan, mint azok akik nem házasok és nincs gyerekük.
Illetve ezeken túl a lakcímek alapján (postal code) egy városrészben lakók közül a leggazdagabb lakóterületiek hajtanak a legtöbbet gyorsan, míg a többi között nem található szignifikáns különbség.
Az utolsó szignifikáns változó az évente megtett mérföldek száma, amely meglepő módon nem pozitív, hanem negatív. Ezt talán az okozhatja, hogy azok akik sokat autóznak, azok kevésbé hajlamosak a gyorshajtásra.
Nem szignifikáns változók
Ellentétben az előző változókkal, nincsen különbség a várható gyorshajtások közt rassz, credit score szerint. Illetve a sportautó, mint autótípus sem növeli a gyorshajtások számát, azonban ezt lehet a kereset változó okozza, hiszen sportautója a tehetős embereknek szokott lenni. Emellett az idősebb (2015 előtti) autók, illetve az autó birtoklása sem okoz kimutatható különbséget.
Modell és valós adat összehasonlítása
df$pred_speeding<- exp(predict(m.nb, df))
plot(df$pred_speeding, df$SPEEDING_VIOLATIONS)
Láthatjuk, hogy a moodell nem tökéletes, azonban mivel az adat nagy része faktor változó, így nehéz megfelelő szinten differenciálni a különböző embereket.