May 4th, 2017
A new day begins, so keep working~
Today's mission:
- Finish the Introduction of the paper.
- Go to the gym for at least half an hour.
- To be continued (maybe a movie?)
The final project for the OCN course
title: "Term Project - Part 3"
subtitle: OCN 682 Introduction to Programming & Statistics in R
Instructor: A.B. Neuheimer
Name: Zhenning Li
INITIALIZATION
rm(list=ls())
require(ggplot2)
require(MASS)
require(car)
require(rms)
require(lme4)
require(MuMIn)
require(visreg)
#As we discussed, I first used the MASS package, but the model result cannot be used for analyzing the residuals and so on. So I changed to the rms package.
DATA
dat=read.csv("C:/Users/User/Google Drive/FIN (Research)-For Zhenning/rural_single_2010-2012_rain.csv")
dat1=dat[,c("sev","dar","daw","dal","mal","fem","you","mid","old")]
#sev-seveirty; dar-dark; daw-dawn; dal-daylight; mal-male; fem-female; you-young; mid-middle; old-old
#The data is differnet with what we dicussed before because I was not allowed to use that data for other use. Therefore, I changed a very similar data for this project. However, the data doesn't contain the detail age of each individual driver, and the age has already changed into catergorcial. The young here means drivers less than 25 years old, middle means drivers are between 26 to 65 years, and the old means the drivers are older than 65 years.
#In order to make the data more clearly, I changed the numeric data into factors.
for (i in 1:length(dat1[1,])){
dat1[,i]=as.factor(dat1[,i])
}
lapply(dat1[, c(1:9)], table)
#sev is categorical without unit and the levels of it are 1, 2, 3, and 4, indicating no injury, minor injury, major injury, and fatal, respectively.
#dar, dal, mal, fem, you, mid, and old are all binary where 1 stands for the crash record has this kind of character, and 0 means the thing didn't happen.
#just in case I need lm() to fit the model
dat2=dat[,c("sev","dar","daw","dal","mal","fem","you","mid","old")]
RESPONSE(S)
What:
The "sev" is the response, it is categorical with four levels.
Motivation:
The severity varies in different traffic crashes because of multiple reasons. Thus, analyzing the reasons of it benefits for the traffic safety.
PREDICTOR(S)
What:
dar, dal, daw, mal, fem, you, mid, and old are the predictors. They are all binary where 1 stands for the crash record has this kind of character, and 0 means the thing didn't happen.
Mechanisms:
Previous studies showed that the driver age is one of the most important contributions to the crash severity. However, the influence mechanism is not clear yet, i.e., the young drivers are more likely to get involved in level 3 accidents but less likely in level 2 accident according to some reports. Thus, I decided to analyze the relationship between the severity and the driver age. Besides, the driver gender together with the light condition may also influence the severity.
HYPOTHESIS
sev~ dar+dal+daw+mal+fem+you+mid+old
STARTING MODEL
Error distribution assumption:
As we discussed before, the error distribution is a multinomial distribution since the multinomial distribution gives the probability of any particular combination of numbers of successes for the various categories.
Shape assumption:
The relationship between the response and the predictors are non-linear. Since the nature of the response is a factor with four ordered levels and the natures of all the predictors are categorical, I decided to choose the ordinal logistic regression.
Fit your starting model:
## fit ordered logit model and store results 'm1', this package can use residual plot, but cannot use the predict
m1=orm(sev~ dar + daw + mal + you + old, data = dat1, x=TRUE, y=TRUE) #In case of rank-deficient, several predictors are deleted. Therefore, the final model is sev~ dar + daw + mal + you + old.
show(m1)
## fit ordered logit model in the other package, the package can use the the predict, but cannot use the residual plot
mx=polr(as.factor(sev)~ dar + daw + mal + you + old, data = dat2)
coeff<-rbind(coef(m1)[-c(1:3)],coef(mx))
##The results are the same
ASSESSING FIT
Predictor multicollinearity:
Are there any issues with predictor multicollinearity? If yes, what do you do?
vif(m1) #All the vif is less than 3 suggesting that the model has no multicollinearity. But I am not sure about whether there is multicollinearity or not in this kind of crash data (we have quite a lot). First, the predictors didn't have any obvious interrelationships between each other since the crashes happen in different places and a different time. I found by Google that somebody said that when using the OLR model, the vif less than 8 means there are no multicollinearity. Besides, somebody also suggested that using the lm() function to find whether the predictors have multicollinearity or not.Therefore, I also designed a linear model.
m2<-lm(sev~ dar + daw + mal + you + old, data = dat2)
vif(m2) #The vifs of all the predictors are quite small. Therefore, the m1 model is a good fit model.
Assessing residuals:
par(mfrow=c(2,4))
colName<-colnames(dat1)
#There are no residual plots for this kind of model, so I tired to use this way to show residuals.
for(i in 2:9){
plot(dat1[,i], resid(m1, type="li.shepherd"),
xlab=colName[i],
ylab="li.shepherd residual")
lines(lowess(dat1[,i], resid(m1, type="li.shepherd")))
points(dat1[,i], resid(m1, type="li.shepherd"))
}
#From the figures we can see that, the means of each box are all near to zero indicating that the residuals are relatively equal.
par(mfrow=c(1,1))
#Besides, I think this one can also be used as residuals.
plot(resid(m1, type="li.shepherd")) #I think the residuals are good enough.
MODEL SELECTION
#Fit a linear model
m2<-lm(sev~ dar + daw + mal + you + old, data = dat2)
#Fit a mixed model, the relationship between male and different age are examined.
m3<-lmer(sev~ dar + daw + (mal|you) + (mal|old),data=dat2)
#model.sel()is not aviable here, so I use the AIC() instead.
AIC(m1)->AICm1; AIC(m2)->AICm2; AIC(m3)->AICm3
order(c(AICm1,AICm2,AICm3)) #The OLR model has the smallest AIC, therefore, it is the best model for this problem
VISUALIZATION
Include at least one visualization showing some aspect of your data as well as your model's fit.
BONUS: Include a map/chart somehow relevant to your term project.
# estimates the values that will be graphed
sf <- function(y) {
c('Y>=1' = qlogis(mean(y >= 1)),
'Y>=2' = qlogis(mean(y >= 2)),
'Y>=3' = qlogis(mean(y >= 3)),
'Y>=4' = qlogis(mean(y >= 4)))
}
# Plot the mean of the data in log scale
s <- with(dat1, summary(as.numeric(sev) ~ dar + daw + mal + you + old, fun=sf))
s[, 5] <- s[, 5] - s[, 4]
s[, 4] <- s[, 4] - s[, 3]
s[, 3] <- s[, 3] - s[, 3]
plot(s, which=1:4, pch=1:4, xlab='logit', main=' ', xlim=range(s[,3:5]))
# Visualizing the fit model
visreg(m1)
REPORTING
##Predict
newdat <- 1-dat2[c(20:5000),-1]
newdat <- cbind(newdat, predict(mx, newdat, type = "probs"))
##show first few rows
head(newdat)
lnewdat <- melt(newdat, id.vars = c("dar", "daw", "dal","mal","fem","you","mid","old"),
variable.name = "Level", value.name="Probability")
for (i in 1:length(lnewdat[1,])){
lnewdat[,i]=as.factor(lnewdat[,i])
}
## view first few rows
head(lnewdat)
##Plot the prediction
ggplot(lnewdat, aes(x = mid, y = as.numeric(Probability), colour = Level)) +
geom_boxplot() + facet_grid(dal ~ mal, labeller="label_both")
# From the plot, we can see that
# 1) When a driver is a middle-age person, the probabilities of the level 1 crashes are decreasing in all the four figures, indicating that the middle-age drivers are more likely to get involved in severe crashes when being compared to other age groups.
# 2) When the light condition is daylight, the drivers are more unlikely to be injured. The reason may be that in the daytime, the drivers usually drive at smaller speeds and more likely to follow the traffic rules. Besides, the high traffic volumes may also be another contributor that the congestion may 'protect' the drivers to some extent.
# 3) The male drivers seem much safer than the female drivers. Their possibilities of getting involved in level 1 crashes are much smaller than those of female drivers. More research should be conducted on analyzing the underlying reasons.
