LAB REPORT 1

Name: GAN ZHI XUAN NO MATRIC: SD23053 SECTION: 02G

  1. Extract data from the following excel file: gmp.txt.
file.choose()
[1] "C:\\Users\\User10\\Desktop\\Statistical Modelling And Simulation\\Lab Report 1\\gmp.txt"
gmp <- read.table("C:\\Users\\User10\\Desktop\\Statistical Modelling And Simulation\\Lab Report 1\\gmp.txt", header=TRUE)
gmp
  1. Develop a multiple linear regression model by considering all variables.
model<-lm(y~x1+x2+x3+x4+x5+x6+x7+x8+x9+x10+x11, data=gmp)
model

Call:
lm(formula = y ~ x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + 
    x10 + x11, data = gmp)

Coefficients:
(Intercept)           x1           x2           x3           x4           x5           x6  
  17.339838    -0.075588    -0.069163     0.115117     1.494737     5.843495     0.317583  
         x7           x8           x9          x10          x11  
  -3.205390     0.180811    -0.397945    -0.005115     0.638483  
summary(model)

Call:
lm(formula = y ~ x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + 
    x10 + x11, data = gmp)

Residuals:
    Min      1Q  Median      3Q     Max 
-5.3441 -1.6711 -0.4486  1.4906  5.2508 

Coefficients:
             Estimate Std. Error t value Pr(>|t|)  
(Intercept) 17.339838  30.355375   0.571   0.5749  
x1          -0.075588   0.056347  -1.341   0.1964  
x2          -0.069163   0.087791  -0.788   0.4411  
x3           0.115117   0.088113   1.306   0.2078  
x4           1.494737   3.101464   0.482   0.6357  
x5           5.843495   3.148438   1.856   0.0799 .
x6           0.317583   1.288967   0.246   0.8082  
x7          -3.205390   3.109185  -1.031   0.3162  
x8           0.180811   0.130301   1.388   0.1822  
x9          -0.397945   0.323456  -1.230   0.2344  
x10         -0.005115   0.005896  -0.868   0.3971  
x11          0.638483   3.021680   0.211   0.8350  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 3.227 on 18 degrees of freedom
  (因为不存在,2个观察量被删除了)
Multiple R-squared:  0.8355,    Adjusted R-squared:  0.7349 
F-statistic:  8.31 on 11 and 18 DF,  p-value: 5.231e-05

Part A

  1. Construct a normal probability plot of the residuals. Does there seem to be any problems with the normality assumption?
model.stdres = rstandard(model)
qqnorm(model.stdres, ylab="Standardized Residuals",  xlab="Normal Scores",  main="Gallon") 
qqline(model.stdres)

Slight deviation appears at the tails, but most points lie close to the straight line, suggesting that residuals are approximately normal.

hist(residuals(model), col = "steelblue", main="Histogram of Residuals", xlab="Residuals")

The shape appears approximately bell-shaped. The residuals are approximately normally distributed.

  1. Support your answer in (i) by using appropriate normality test.
shapiro.test(model.stdres)

    Shapiro-Wilk normality test

data:  model.stdres
W = 0.96009, p-value = 0.3113

W is a test statistics values.

\(H_{0}\): The data is normally distributed.

\(H_{1}\): The data is not normally distributed.

\(p-value=0.3113\)

Since \((p-value=0.3113)>(\alpha=0.05)\), do not reject \(H_{0}\)

At \(\alpha=0.05\), the data is normally distributed.

  1. Construct and interpret a plot of residuals versus the predicted response.
yhat<- predict(model)   
epsilon <- residuals(model)
plot(cbind(yhat,epsilon), xlab="Predicted values", ylab="Residuals", main="Residuals vs Predicted")
abline(h = 0, lty = 2)

Interpretation:

-A horizontal band of residuals with no pattern. Therefore, linearity and homoscedasticity likely hold.

-The assumption of linearity appears satisfied. The residuals appear randomly distributed across the range of fitted values without any systematic curve or trend.

-The independence assumption appears reasonable. The residuals appear independent, showing no sequential structure or visible dependency.

-The scatter plot alone doesn’t clearly indicate normality.

-The equality of variances assumption appears satisfied. The spread of residuals appears quite uniform across the range of yhat and no funneling or widening pattern.

Part B

Then, detect any outliers occurs using Cook’s Distance method.

pairs(gmp)

round(cor(gmp),4)
          y      x1      x2 x3      x4      x5      x6      x7      x8      x9     x10     x11
y    1.0000 -0.8788 -0.8069 NA  0.3565  0.5948 -0.4870  0.7220 -0.7546 -0.7731 -0.8629 -0.7451
x1  -0.8788  1.0000  0.9452 NA -0.3302 -0.6316  0.6591 -0.7815  0.8552  0.8014  0.9457  0.8354
x2  -0.8069  0.9452  1.0000 NA -0.2921 -0.5170  0.7719 -0.6432  0.7974  0.7176  0.8834  0.7267
x3       NA      NA      NA  1      NA      NA      NA      NA      NA      NA      NA      NA
x4   0.3565 -0.3302 -0.2921 NA  1.0000  0.3737 -0.0493  0.4938 -0.2581 -0.3188 -0.2772 -0.3684
x5   0.5948 -0.6316 -0.5170 NA  0.3737  1.0000 -0.2054  0.8429 -0.5481 -0.4344 -0.5424 -0.7032
x6  -0.4870  0.6591  0.7719 NA -0.0493 -0.2054  1.0000 -0.3006  0.4252  0.3157  0.5206  0.4173
x7   0.7220 -0.7815 -0.6432 NA  0.4938  0.8429 -0.3006  1.0000 -0.6631 -0.6682 -0.7178 -0.8550
x8  -0.7546  0.8552  0.7974 NA -0.2581 -0.5481  0.4252 -0.6631  1.0000  0.8850  0.9476  0.6863
x9  -0.7731  0.8014  0.7176 NA -0.3188 -0.4344  0.3157 -0.6682  0.8850  1.0000  0.9015  0.6507
x10 -0.8629  0.9457  0.8834 NA -0.2772 -0.5424  0.5206 -0.7178  0.9476  0.9015  1.0000  0.7722
x11 -0.7451  0.8354  0.7267 NA -0.3684 -0.7032  0.4173 -0.8550  0.6863  0.6507  0.7722  1.0000
cooksd <- cooks.distance(model)
  1. Plot the influential observation by Cook’s Distance and comments.
plot(cooksd, pch="*", cex=2, main="Influential Obs by Cooks distance") 
abline(h = 4*mean(cooksd, na.rm=T), col="red")  
text(x=1:length(cooksd)+1, y=cooksd, labels=ifelse(cooksd>4*mean(cooksd, na.rm=T),names(cooksd),""), col="red")

Interpretation:

There are two outliers which are 14 and 17. Observations 14 and 17 exceed the Cook’s distance cutoff, so they are influential. A point is considered influential if Cook’s D > (4×mean(D)).

  1. Examine and list the point observation(s) which consider as outlier(s). Justify your answer.
influential <- as.numeric(names(cooksd)[(cooksd > 4*mean(cooksd, na.rm=T))])  
head(gmp[influential, ])

Interpretation:

The point observations are row 14 and 17.

Row 14 has very high y. Row 17 has very high x10. These points likely influence model estimates due to their extreme response or predictor values. Further examination may be needed to decide if they should be removed.

Part C

  1. By considering only x1, x2, x3, x8, x9 and x10, construct the lack of fit test. Interpret and justify your answer.
sub_model<-lm(y~x1+x2+x3+x8+x9+x10, data=gmp)
summary(sub_model)

Call:
lm(formula = y ~ x1 + x2 + x3 + x8 + x9 + x10, data = gmp)

Residuals:
    Min      1Q  Median      3Q     Max 
-4.7829 -1.6308 -0.2023  1.7894  6.2575 

Coefficients:
             Estimate Std. Error t value Pr(>|t|)
(Intercept) 31.891090  19.188065   1.662    0.110
x1          -0.051858   0.044919  -1.154    0.260
x2           0.001803   0.056564   0.032    0.975
x3           0.031761   0.070140   0.453    0.655
x8           0.129341   0.116709   1.108    0.279
x9          -0.206554   0.275463  -0.750    0.461
x10         -0.003947   0.004986  -0.792    0.437

Residual standard error: 3.206 on 23 degrees of freedom
  (因为不存在,2个观察量被删除了)
Multiple R-squared:  0.7924,    Adjusted R-squared:  0.7383 
F-statistic: 14.64 on 6 and 23 DF,  p-value: 7.75e-07
anova(model,sub_model)
Analysis of Variance Table

Model 1: y ~ x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11
Model 2: y ~ x1 + x2 + x3 + x8 + x9 + x10
  Res.Df    RSS Df Sum of Sq      F Pr(>F)
1     18 187.40                           
2     23 236.43 -5   -49.024 0.9418  0.478

\(H_{0}\): Full model do not offers a statistically better fit than the reduced model.

\(H_{1}\): Full model offers a statistically better fit than the reduced model.

\(p-value=0.4780\)

Since \((p-value=0.4780)>(\alpha=0.05)\), do not reject \(H_{0}\)

At \(\alpha=0.05\), full model do not offers a statistically better fit than the reduced model.

LS0tDQp0aXRsZTogIlIgTm90ZWJvb2siDQpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sNCi0tLQ0KTEFCIFJFUE9SVCAxDQoNCk5hbWU6IEdBTiBaSEkgWFVBTiAgICAgIE5PIE1BVFJJQzogU0QyMzA1MyAgICAgIFNFQ1RJT046IDAyRw0KDQoxLiBFeHRyYWN0IGRhdGEgZnJvbSB0aGUgZm9sbG93aW5nIGV4Y2VsIGZpbGU6IGdtcC50eHQuDQpgYGB7cn0NCmZpbGUuY2hvb3NlKCkNCmBgYA0KDQpgYGB7cn0NCmdtcCA8LSByZWFkLnRhYmxlKCJDOlxcVXNlcnNcXFVzZXIxMFxcRGVza3RvcFxcU3RhdGlzdGljYWwgTW9kZWxsaW5nIEFuZCBTaW11bGF0aW9uXFxMYWIgUmVwb3J0IDFcXGdtcC50eHQiLCBoZWFkZXI9VFJVRSkNCmdtcA0KYGBgDQoNCg0KMi4gRGV2ZWxvcCBhIG11bHRpcGxlIGxpbmVhciByZWdyZXNzaW9uIG1vZGVsIGJ5IGNvbnNpZGVyaW5nIGFsbCB2YXJpYWJsZXMuDQpgYGB7cn0NCm1vZGVsPC1sbSh5fngxK3gyK3gzK3g0K3g1K3g2K3g3K3g4K3g5K3gxMCt4MTEsIGRhdGE9Z21wKQ0KbW9kZWwNCmBgYA0KYGBge3J9DQpzdW1tYXJ5KG1vZGVsKQ0KYGBgDQoNCg0KUGFydCBBDQoNCmkpIENvbnN0cnVjdCBhIG5vcm1hbCBwcm9iYWJpbGl0eSBwbG90IG9mIHRoZSByZXNpZHVhbHMuIERvZXMgdGhlcmUgc2VlbSB0byBiZSBhbnkgcHJvYmxlbXMgd2l0aCB0aGUgbm9ybWFsaXR5IGFzc3VtcHRpb24/DQpgYGB7cn0NCm1vZGVsLnN0ZHJlcyA9IHJzdGFuZGFyZChtb2RlbCkNCnFxbm9ybShtb2RlbC5zdGRyZXMsIHlsYWI9IlN0YW5kYXJkaXplZCBSZXNpZHVhbHMiLCAgeGxhYj0iTm9ybWFsIFNjb3JlcyIsICBtYWluPSJHYWxsb24iKSANCnFxbGluZShtb2RlbC5zdGRyZXMpDQpgYGANClNsaWdodCBkZXZpYXRpb24gYXBwZWFycyBhdCB0aGUgdGFpbHMsIGJ1dCBtb3N0IHBvaW50cyBsaWUgY2xvc2UgdG8gdGhlIHN0cmFpZ2h0IGxpbmUsIHN1Z2dlc3RpbmcgdGhhdCByZXNpZHVhbHMgYXJlIGFwcHJveGltYXRlbHkgbm9ybWFsLg0KDQpgYGB7cn0NCmhpc3QocmVzaWR1YWxzKG1vZGVsKSwgY29sID0gInN0ZWVsYmx1ZSIsIG1haW49Ikhpc3RvZ3JhbSBvZiBSZXNpZHVhbHMiLCB4bGFiPSJSZXNpZHVhbHMiKQ0KYGBgDQpUaGUgc2hhcGUgYXBwZWFycyBhcHByb3hpbWF0ZWx5IGJlbGwtc2hhcGVkLiBUaGUgcmVzaWR1YWxzIGFyZSBhcHByb3hpbWF0ZWx5IG5vcm1hbGx5IGRpc3RyaWJ1dGVkLg0KDQoNCmlpKSBTdXBwb3J0IHlvdXIgYW5zd2VyIGluIChpKSBieSB1c2luZyBhcHByb3ByaWF0ZSBub3JtYWxpdHkgdGVzdC4NCmBgYHtyfQ0Kc2hhcGlyby50ZXN0KG1vZGVsLnN0ZHJlcykNCmBgYA0KVyBpcyBhIHRlc3Qgc3RhdGlzdGljcyB2YWx1ZXMuIA0KDQokSF97MH0kOiBUaGUgZGF0YSBpcyBub3JtYWxseSBkaXN0cmlidXRlZC4gDQoNCiRIX3sxfSQ6IFRoZSBkYXRhIGlzIG5vdCBub3JtYWxseSBkaXN0cmlidXRlZC4gDQoNCiRwLXZhbHVlPTAuMzExMyQNCg0KU2luY2UgJChwLXZhbHVlPTAuMzExMyk+KFxhbHBoYT0wLjA1KSQsIGRvIG5vdCByZWplY3QgJEhfezB9JA0KDQpBdCAkXGFscGhhPTAuMDUkLCB0aGUgZGF0YSBpcyBub3JtYWxseSBkaXN0cmlidXRlZC4NCg0KDQppaWkpIENvbnN0cnVjdCBhbmQgaW50ZXJwcmV0IGEgcGxvdCBvZiByZXNpZHVhbHMgdmVyc3VzIHRoZSBwcmVkaWN0ZWQgcmVzcG9uc2UuDQpgYGB7cn0NCnloYXQ8LSBwcmVkaWN0KG1vZGVsKSAgIA0KZXBzaWxvbiA8LSByZXNpZHVhbHMobW9kZWwpDQpwbG90KGNiaW5kKHloYXQsZXBzaWxvbiksIHhsYWI9IlByZWRpY3RlZCB2YWx1ZXMiLCB5bGFiPSJSZXNpZHVhbHMiLCBtYWluPSJSZXNpZHVhbHMgdnMgUHJlZGljdGVkIikNCmFibGluZShoID0gMCwgbHR5ID0gMikNCmBgYA0KSW50ZXJwcmV0YXRpb246DQoNCi1BIGhvcml6b250YWwgYmFuZCBvZiByZXNpZHVhbHMgd2l0aCBubyBwYXR0ZXJuLiBUaGVyZWZvcmUsIGxpbmVhcml0eSBhbmQgaG9tb3NjZWRhc3RpY2l0eSBsaWtlbHkgaG9sZC4NCg0KLVRoZSBhc3N1bXB0aW9uIG9mIGxpbmVhcml0eSBhcHBlYXJzIHNhdGlzZmllZC4gVGhlIHJlc2lkdWFscyBhcHBlYXIgcmFuZG9tbHkgZGlzdHJpYnV0ZWQgYWNyb3NzIHRoZSByYW5nZSBvZiBmaXR0ZWQgdmFsdWVzIHdpdGhvdXQgYW55IHN5c3RlbWF0aWMgY3VydmUgb3IgdHJlbmQuDQoNCi1UaGUgaW5kZXBlbmRlbmNlIGFzc3VtcHRpb24gYXBwZWFycyByZWFzb25hYmxlLiBUaGUgcmVzaWR1YWxzIGFwcGVhciBpbmRlcGVuZGVudCwgc2hvd2luZyBubyBzZXF1ZW50aWFsIHN0cnVjdHVyZSBvciB2aXNpYmxlIGRlcGVuZGVuY3kuDQoNCi1UaGUgc2NhdHRlciBwbG90IGFsb25lIGRvZXNu4oCZdCBjbGVhcmx5IGluZGljYXRlIG5vcm1hbGl0eS4NCg0KLVRoZSBlcXVhbGl0eSBvZiB2YXJpYW5jZXMgYXNzdW1wdGlvbiBhcHBlYXJzIHNhdGlzZmllZC4gVGhlIHNwcmVhZCBvZiByZXNpZHVhbHMgYXBwZWFycyBxdWl0ZSB1bmlmb3JtIGFjcm9zcyB0aGUgcmFuZ2Ugb2YgeWhhdCBhbmQgbm8gZnVubmVsaW5nIG9yIHdpZGVuaW5nIHBhdHRlcm4uDQoNCg0KUGFydCBCDQoNClRoZW4sIGRldGVjdCBhbnkgb3V0bGllcnMgb2NjdXJzIHVzaW5nIENvb2vigJlzIERpc3RhbmNlIG1ldGhvZC4NCmBgYHtyfQ0KcGFpcnMoZ21wKQ0Kcm91bmQoY29yKGdtcCksNCkNCmNvb2tzZCA8LSBjb29rcy5kaXN0YW5jZShtb2RlbCkNCmBgYA0KDQppKSBQbG90IHRoZSBpbmZsdWVudGlhbCBvYnNlcnZhdGlvbiBieSBDb29r4oCZcyBEaXN0YW5jZSBhbmQgY29tbWVudHMuDQpgYGB7cn0NCnBsb3QoY29va3NkLCBwY2g9IioiLCBjZXg9MiwgbWFpbj0iSW5mbHVlbnRpYWwgT2JzIGJ5IENvb2tzIGRpc3RhbmNlIikgDQphYmxpbmUoaCA9IDQqbWVhbihjb29rc2QsIG5hLnJtPVQpLCBjb2w9InJlZCIpICANCnRleHQoeD0xOmxlbmd0aChjb29rc2QpKzEsIHk9Y29va3NkLCBsYWJlbHM9aWZlbHNlKGNvb2tzZD40Km1lYW4oY29va3NkLCBuYS5ybT1UKSxuYW1lcyhjb29rc2QpLCIiKSwgY29sPSJyZWQiKQ0KYGBgDQpJbnRlcnByZXRhdGlvbjoNCg0KVGhlcmUgYXJlIHR3byBvdXRsaWVycyB3aGljaCBhcmUgMTQgYW5kIDE3Lg0KT2JzZXJ2YXRpb25zIDE0IGFuZCAxNyBleGNlZWQgdGhlIENvb2sncyBkaXN0YW5jZSBjdXRvZmYsIHNvIHRoZXkgYXJlIGluZmx1ZW50aWFsLg0KQSBwb2ludCBpcyBjb25zaWRlcmVkIGluZmx1ZW50aWFsIGlmIENvb2vigJlzIEQgPiAoNMOXbWVhbihEKSkuDQoNCg0KaWkpIEV4YW1pbmUgYW5kIGxpc3QgdGhlIHBvaW50IG9ic2VydmF0aW9uKHMpIHdoaWNoIGNvbnNpZGVyIGFzIG91dGxpZXIocykuIEp1c3RpZnkgeW91ciBhbnN3ZXIuDQpgYGB7cn0NCmluZmx1ZW50aWFsIDwtIGFzLm51bWVyaWMobmFtZXMoY29va3NkKVsoY29va3NkID4gNCptZWFuKGNvb2tzZCwgbmEucm09VCkpXSkgIA0KaGVhZChnbXBbaW5mbHVlbnRpYWwsIF0pDQpgYGANCkludGVycHJldGF0aW9uOg0KDQpUaGUgcG9pbnQgb2JzZXJ2YXRpb25zIGFyZSByb3cgMTQgYW5kIDE3Lg0KDQpSb3cgMTQgaGFzIHZlcnkgaGlnaCB5Lg0KUm93IDE3IGhhcyB2ZXJ5IGhpZ2ggeDEwLiANClRoZXNlIHBvaW50cyBsaWtlbHkgaW5mbHVlbmNlIG1vZGVsIGVzdGltYXRlcyBkdWUgdG8gdGhlaXIgZXh0cmVtZSByZXNwb25zZSBvciBwcmVkaWN0b3IgdmFsdWVzLiBGdXJ0aGVyIGV4YW1pbmF0aW9uIG1heSBiZSBuZWVkZWQgdG8gZGVjaWRlIGlmIHRoZXkgc2hvdWxkIGJlIHJlbW92ZWQuDQoNClBhcnQgQw0KDQppKSBCeSBjb25zaWRlcmluZyBvbmx5IHgxLCB4MiwgeDMsIHg4LCB4OSBhbmQgeDEwLCBjb25zdHJ1Y3QgdGhlIGxhY2sgb2YgZml0IHRlc3QuIEludGVycHJldCBhbmQganVzdGlmeSB5b3VyIGFuc3dlci4NCmBgYHtyfQ0Kc3ViX21vZGVsPC1sbSh5fngxK3gyK3gzK3g4K3g5K3gxMCwgZGF0YT1nbXApDQpzdW1tYXJ5KHN1Yl9tb2RlbCkNCmBgYA0KYGBge3J9DQphbm92YShtb2RlbCxzdWJfbW9kZWwpDQpgYGANCiRIX3swfSQ6IEZ1bGwgbW9kZWwgZG8gbm90IG9mZmVycyBhIHN0YXRpc3RpY2FsbHkgYmV0dGVyIGZpdCB0aGFuIHRoZSByZWR1Y2VkIG1vZGVsLg0KDQokSF97MX0kOiBGdWxsIG1vZGVsIG9mZmVycyBhIHN0YXRpc3RpY2FsbHkgYmV0dGVyIGZpdCB0aGFuIHRoZSByZWR1Y2VkIG1vZGVsLg0KDQokcC12YWx1ZT0wLjQ3ODAkDQoNClNpbmNlICQocC12YWx1ZT0wLjQ3ODApPihcYWxwaGE9MC4wNSkkLCBkbyBub3QgcmVqZWN0ICRIX3swfSQNCg0KQXQgJFxhbHBoYT0wLjA1JCwgZnVsbCBtb2RlbCBkbyBub3Qgb2ZmZXJzIGEgc3RhdGlzdGljYWxseSBiZXR0ZXIgZml0IHRoYW4gdGhlIHJlZHVjZWQgbW9kZWwuDQo=