Random slopes model
Following up from practical 2, we will continue to build up our
multilevel model for school effects by adding a random slope for prior
attainment.
Task 1: Fit a random slopes model
We have theoretical reasons to believe that the effect of KS2 varies
across schools, since some schools do seem to make their pupils progress
more than others. To test this hypothesis, we fit a
random slopes model by running the following code:
m1_rs <- lmer(ks4stand ~ as.vector(scale(ks2stand))+
(1 + as.vector(scale(ks2stand))|schoolID), data = valueadded, REML = F)
# Note that KS2 have been added like this "as.vector(scale(ks2stand))". This is done to prevent a convergence error. The function "scale" rescales KS2 scores to units of standard deviation, i.e. it "standardises".
summary(m1_rs)
## Linear mixed model fit by maximum likelihood ['lmerMod']
## Formula:
## ks4stand ~ as.vector(scale(ks2stand)) + (1 + as.vector(scale(ks2stand)) |
## schoolID)
## Data: valueadded
##
## AIC BIC logLik deviance df.resid
## 94083.5 94128.8 -47035.7 94071.5 14046
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -4.9474 -0.5315 0.0255 0.5764 4.5486
##
## Random effects:
## Groups Name Variance Std.Dev. Corr
## schoolID (Intercept) 8.964 2.994
## as.vector(scale(ks2stand)) 1.295 1.138 0.50
## Residual 43.160 6.570
## Number of obs: 14052, groups: schoolID, 628
##
## Fixed effects:
## Estimate Std. Error t value
## (Intercept) -0.11737 0.13375 -0.877
## as.vector(scale(ks2stand)) 6.42098 0.07797 82.353
##
## Correlation of Fixed Effects:
## (Intr)
## as.vct((2)) 0.282
Question
1.1. What is the correlation between the intercept and the slope?
1.2. What sort of pattern is it?
Task 2: Compare the fit of the random slopes model to the random
intercepts model
To compare the random intercepts models with the
random slopes model, we first run the random intercepts
model again
m1 <- lmer(ks4stand ~ ks2stand + (1|schoolID), data = valueadded, REML = F)
anova(m1, m1_rs)
## Data: valueadded
## Models:
## m1: ks4stand ~ ks2stand + (1 | schoolID)
## m1_rs: ks4stand ~ as.vector(scale(ks2stand)) + (1 + as.vector(scale(ks2stand)) | schoolID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## m1 4 94184 94215 -47088 94176
## m1_rs 6 94083 94129 -47036 94071 104.87 2 < 2.2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
And then we compare using the anova function in R:
anova(m1, m1_rs)
## Data: valueadded
## Models:
## m1: ks4stand ~ ks2stand + (1 | schoolID)
## m1_rs: ks4stand ~ as.vector(scale(ks2stand)) + (1 + as.vector(scale(ks2stand)) | schoolID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## m1 4 94184 94215 -47088 94176
## m1_rs 6 94083 94129 -47036 94071 104.87 2 < 2.2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
Question:
2.1. Is the random slope specification a significant addition to the
model?
The results indicate that, even though more complex (2 extra
parameters), the random slopes model has a significantly
better fit than the random intercepts model.
Task 3: Visualising results
To plot the school predicted lines, we can retrieve the fitted values
from the model m1_rs, as such:
valueadded2 <- filter(valueadded, !is.na(ks4stand) & !is.na(ks2stand)) # this filter is necessary to avoid issues with missing values
valueadded2$pred_rs<-fitted(m1_rs)
Then we can plot the predicted school results by typing:
school_plot_rs<-ggplot(valueadded2, aes(x=ks2stand, y=pred_rs, group=factor(schoolID))) +
geom_smooth(method="lm", colour="black") +
xlab("Standardised KS2 score") +
ylab("Predicted KS4 score") +
theme_bw()
school_plot_rs

Voilà! School predicted scores have varying slopes for the
relationship between KS2 and GCSE scores. You can see that pupils in
some schools make more progress than others on average and some make
less.
Question
3.1. What sort of pattern is this?
Task 4: Checking assumptions
We will check the assumptions for the random intercepts
model (m1).
You can also plot the higher-level (school) residuals to check for
normality
u0 <- ranef(m1, condVar = TRUE) # These are the residuals from model "m1"
hist(u0$schoolID$`(Intercept)`) # Histogram for school residuals

You can also plot individual-level to check for normality
valueadded2$ind_resid <- residuals(m1)
hist(valueadded2$ind_resid)

And finally, you can plot individual-level residuals against the
predicted values:
valueadded2$pred <- fitted(m1) # retrieve predicted values from model m1
homoscedasticity <- ggplot(valueadded2, aes(y = ind_resid, x = pred)) + geom_point()
homoscedasticity

Questions
4.1. Is the normality assumption reasonable at the school level?
4.2. Is the normality assumption reasonable at the pupil level?
4.3. Is it reasonable to assume homoscedasticity?
LS0tDQp0aXRsZTogIkludHJvIHRvIE1MTTogUHJhY3RpY2FsIDQiDQphdXRob3I6IFBhdHJpY2lvIFRyb25jb3NvIGFuZCBBbmEgTW9yYWxlcy1Hw7NtZXoNCmRhdGU6ICJKdW5lIDIwMjIiDQpvdXRwdXQ6IA0KICBodG1sX2RvY3VtZW50Og0KICAgIGNvZGVfZG93bmxvYWQ6IHllcw0KICAgIGhpZ2hsaWdodGVyOiBudWxsDQogICAgdGhlbWU6IGNvc21vDQogICAgdG9jOiB5ZXMNCiAgICB0b2NfZGVwdGg6IDQNCiAgICB0b2NfZmxvYXQ6IHllcw0KICAgIGZvbnRzaXplOiAxMnB0DQotLS0NCmBgYHtyIHNldHVwLCBpbmNsdWRlPUZBTFNFfQ0Ka25pdHI6Om9wdHNfY2h1bmskc2V0KGVjaG8gPSBUUlVFKQ0KbGlicmFyeShoYXZlbikNCmxpYnJhcnkobG1lNCkNCmxpYnJhcnkoZ2dwbG90MikNCmxpYnJhcnkoZHBseXIpDQp5cGU8LXJlYWRfc2F2KCJodHRwczovL2dpdGh1Yi5jb20vQS1tb3JhL01MTV9zdW1tZXItc2Nob29sL3Jhdy9tYWluL2RhdGEvbHN5cGVfMTUwMDBfZmluYWxfMjAxMV8wNV8wNC5zYXYiKQ0KdmFsdWVhZGRlZCA8LSBzZWxlY3QoeXBlLCBwdXBpbGlkLCBzY2hvb2xJRCwgDQogICAgICAgICAgICAgICAgICAgICBrczJzdGFuZCwga3M0c3RhbmQsIGdlbmRlciwgDQogICAgICAgICAgICAgICAgICAgICBmc20pDQpgYGANCg0KIyBSYW5kb20gc2xvcGVzIG1vZGVsDQoNCkZvbGxvd2luZyB1cCBmcm9tIHByYWN0aWNhbCAyLCB3ZSB3aWxsIGNvbnRpbnVlIHRvIGJ1aWxkIHVwIG91ciBtdWx0aWxldmVsIG1vZGVsIGZvciBzY2hvb2wgZWZmZWN0cyBieSBhZGRpbmcgYSByYW5kb20gc2xvcGUgZm9yIHByaW9yIGF0dGFpbm1lbnQuDQoNCioqKg0KDQojIFRhc2sgMTogRml0IGEgcmFuZG9tIHNsb3BlcyBtb2RlbA0KDQpXZSBoYXZlIHRoZW9yZXRpY2FsIHJlYXNvbnMgdG8gYmVsaWV2ZSB0aGF0IHRoZSBlZmZlY3Qgb2YgS1MyIHZhcmllcyBhY3Jvc3Mgc2Nob29scywgc2luY2Ugc29tZSBzY2hvb2xzIGRvIHNlZW0gdG8gbWFrZSB0aGVpciBwdXBpbHMgcHJvZ3Jlc3MgbW9yZSB0aGFuIG90aGVycy4gVG8gdGVzdCB0aGlzIGh5cG90aGVzaXMsIHdlIGZpdCBhIGByYW5kb20gc2xvcGVzIG1vZGVsYCBieSBydW5uaW5nIHRoZSBmb2xsb3dpbmcgY29kZTogDQoNCmBgYHtyLCB3YXJuaW5nPUYsIG1lc3NhZ2U9Rn0NCg0KbTFfcnMgPC0gbG1lcihrczRzdGFuZCB+IGFzLnZlY3RvcihzY2FsZShrczJzdGFuZCkpKw0KICAgICAgICAgICAgICAoMSArIGFzLnZlY3RvcihzY2FsZShrczJzdGFuZCkpfHNjaG9vbElEKSwgZGF0YSA9IHZhbHVlYWRkZWQsIFJFTUwgPSBGKQ0KDQojIE5vdGUgdGhhdCBLUzIgaGF2ZSBiZWVuIGFkZGVkIGxpa2UgdGhpcyAiYXMudmVjdG9yKHNjYWxlKGtzMnN0YW5kKSkiLiBUaGlzIGlzIGRvbmUgdG8gcHJldmVudCBhIGNvbnZlcmdlbmNlIGVycm9yLiBUaGUgZnVuY3Rpb24gInNjYWxlIiByZXNjYWxlcyBLUzIgc2NvcmVzIHRvIHVuaXRzIG9mIHN0YW5kYXJkIGRldmlhdGlvbiwgaS5lLiBpdCAic3RhbmRhcmRpc2VzIi4NCg0Kc3VtbWFyeShtMV9ycykNCmBgYA0KDQojIyMgUXVlc3Rpb24NCg0KMS4xLiBXaGF0IGlzIHRoZSBjb3JyZWxhdGlvbiBiZXR3ZWVuIHRoZSBpbnRlcmNlcHQgYW5kIHRoZSBzbG9wZT8NCg0KMS4yLiBXaGF0IHNvcnQgb2YgcGF0dGVybiBpcyBpdD8NCg0KKioqDQoNCiMgVGFzayAyOiBDb21wYXJlIHRoZSBmaXQgb2YgdGhlIHJhbmRvbSBzbG9wZXMgbW9kZWwgdG8gdGhlIHJhbmRvbSBpbnRlcmNlcHRzIG1vZGVsDQoNClRvIGNvbXBhcmUgdGhlIGByYW5kb20gaW50ZXJjZXB0cyBtb2RlbHNgIHdpdGggdGhlIGByYW5kb20gc2xvcGVzIG1vZGVsYCwgd2UgZmlyc3QgcnVuIHRoZSByYW5kb20gaW50ZXJjZXB0cyBtb2RlbCBhZ2Fpbg0KDQpgYGB7ciwgd2FybmluZz1GLCBtZXNzYWdlPUZ9DQptMSA8LSBsbWVyKGtzNHN0YW5kIH4ga3Myc3RhbmQgKyAoMXxzY2hvb2xJRCksIGRhdGEgPSB2YWx1ZWFkZGVkLCBSRU1MID0gRikNCmFub3ZhKG0xLCBtMV9ycykNCmBgYA0KDQpBbmQgdGhlbiB3ZSBjb21wYXJlIHVzaW5nIHRoZSBgYW5vdmFgIGZ1bmN0aW9uIGluIFI6DQoNCmBgYHtyLCB3YXJuaW5nPUYsIG1lc3NhZ2U9Rn0NCmFub3ZhKG0xLCBtMV9ycykNCmBgYA0KDQojIyMgUXVlc3Rpb246DQoNCjIuMS4gSXMgdGhlIHJhbmRvbSBzbG9wZSBzcGVjaWZpY2F0aW9uIGEgc2lnbmlmaWNhbnQgYWRkaXRpb24gdG8gdGhlIG1vZGVsPw0KDQpUaGUgcmVzdWx0cyBpbmRpY2F0ZSB0aGF0LCBldmVuIHRob3VnaCBtb3JlIGNvbXBsZXggKDIgZXh0cmEgcGFyYW1ldGVycyksIHRoZSBgcmFuZG9tIHNsb3BlcyBtb2RlbGAgaGFzIGEgc2lnbmlmaWNhbnRseSBiZXR0ZXIgZml0IHRoYW4gdGhlIGByYW5kb20gaW50ZXJjZXB0cyBtb2RlbGAuDQoNCioqKg0KDQojIFRhc2sgMzogVmlzdWFsaXNpbmcgcmVzdWx0cw0KDQpUbyBwbG90IHRoZSBzY2hvb2wgcHJlZGljdGVkIGxpbmVzLCB3ZSBjYW4gcmV0cmlldmUgdGhlIGZpdHRlZCB2YWx1ZXMgZnJvbSB0aGUgbW9kZWwgYG0xX3JzYCwgYXMgc3VjaDoNCg0KYGBge3IsIHdhcm5pbmc9RiwgbWVzc2FnZT1GfQ0KdmFsdWVhZGRlZDIgPC0gZmlsdGVyKHZhbHVlYWRkZWQsICFpcy5uYShrczRzdGFuZCkgJiAhaXMubmEoa3Myc3RhbmQpKSAjIHRoaXMgZmlsdGVyIGlzIG5lY2Vzc2FyeSB0byBhdm9pZCBpc3N1ZXMgd2l0aCBtaXNzaW5nIHZhbHVlcw0KDQp2YWx1ZWFkZGVkMiRwcmVkX3JzPC1maXR0ZWQobTFfcnMpDQpgYGANCg0KVGhlbiB3ZSBjYW4gcGxvdCB0aGUgcHJlZGljdGVkIHNjaG9vbCByZXN1bHRzIGJ5IHR5cGluZzoNCg0KYGBge3IsIHdhcm5pbmc9RiwgbWVzc2FnZT1GfQ0Kc2Nob29sX3Bsb3RfcnM8LWdncGxvdCh2YWx1ZWFkZGVkMiwgYWVzKHg9a3Myc3RhbmQsIHk9cHJlZF9ycywgZ3JvdXA9ZmFjdG9yKHNjaG9vbElEKSkpICsgDQogIGdlb21fc21vb3RoKG1ldGhvZD0ibG0iLCBjb2xvdXI9ImJsYWNrIikgKw0KICB4bGFiKCJTdGFuZGFyZGlzZWQgS1MyIHNjb3JlIikgKw0KICB5bGFiKCJQcmVkaWN0ZWQgS1M0IHNjb3JlIikgKw0KICB0aGVtZV9idygpDQoNCnNjaG9vbF9wbG90X3JzDQpgYGANCg0KVm9pbMOgISBTY2hvb2wgcHJlZGljdGVkIHNjb3JlcyBoYXZlIHZhcnlpbmcgc2xvcGVzIGZvciB0aGUgcmVsYXRpb25zaGlwIGJldHdlZW4gS1MyIGFuZCBHQ1NFIHNjb3Jlcy4gWW91IGNhbiBzZWUgdGhhdCBwdXBpbHMgaW4gc29tZSBzY2hvb2xzIG1ha2UgbW9yZSBwcm9ncmVzcyB0aGFuIG90aGVycyBvbiBhdmVyYWdlIGFuZCBzb21lIG1ha2UgbGVzcy4gDQoNCiMjIyBRdWVzdGlvbg0KDQozLjEuIFdoYXQgc29ydCBvZiBwYXR0ZXJuIGlzIHRoaXM/DQoNCjxicj4NCg0KKioqDQoNCiMgVGFzayA0OiBDaGVja2luZyBhc3N1bXB0aW9ucw0KDQpXZSB3aWxsIGNoZWNrIHRoZSBhc3N1bXB0aW9ucyBmb3IgdGhlIGByYW5kb20gaW50ZXJjZXB0c2AgbW9kZWwgKCoqbTEqKikuIA0KDQpZb3UgY2FuIGFsc28gcGxvdCB0aGUgaGlnaGVyLWxldmVsIChzY2hvb2wpIHJlc2lkdWFscyB0byBjaGVjayBmb3Igbm9ybWFsaXR5DQoNCmBgYHtyLCB3YXJuaW5nPUYsIG1lc3NhZ2U9Rn0NCnUwIDwtIHJhbmVmKG0xLCBjb25kVmFyID0gVFJVRSkgIyBUaGVzZSBhcmUgdGhlIHJlc2lkdWFscyBmcm9tIG1vZGVsICJtMSINCg0KaGlzdCh1MCRzY2hvb2xJRCRgKEludGVyY2VwdClgKSAjIEhpc3RvZ3JhbSBmb3Igc2Nob29sIHJlc2lkdWFscw0KYGBgDQoNCllvdSBjYW4gYWxzbyBwbG90IGluZGl2aWR1YWwtbGV2ZWwgdG8gY2hlY2sgZm9yIG5vcm1hbGl0eQ0KDQpgYGB7ciwgd2FybmluZz1GLCBtZXNzYWdlPUZ9DQoNCnZhbHVlYWRkZWQyJGluZF9yZXNpZCA8LSByZXNpZHVhbHMobTEpDQoNCmhpc3QodmFsdWVhZGRlZDIkaW5kX3Jlc2lkKQ0KDQpgYGANCg0KQW5kIGZpbmFsbHksIHlvdSBjYW4gcGxvdCBpbmRpdmlkdWFsLWxldmVsIHJlc2lkdWFscyBhZ2FpbnN0IHRoZSBwcmVkaWN0ZWQgdmFsdWVzOg0KDQpgYGB7ciwgd2FybmluZz1GLCBtZXNzYWdlPUZ9DQoNCnZhbHVlYWRkZWQyJHByZWQgPC0gZml0dGVkKG0xKSAjIHJldHJpZXZlIHByZWRpY3RlZCB2YWx1ZXMgZnJvbSBtb2RlbCBtMQ0KDQpob21vc2NlZGFzdGljaXR5IDwtIGdncGxvdCh2YWx1ZWFkZGVkMiwgYWVzKHkgPSBpbmRfcmVzaWQsIHggPSBwcmVkKSkgKyBnZW9tX3BvaW50KCkNCg0KaG9tb3NjZWRhc3RpY2l0eQ0KDQpgYGANCg0KIyMjIFF1ZXN0aW9ucw0KDQo0LjEuIElzIHRoZSBub3JtYWxpdHkgYXNzdW1wdGlvbiByZWFzb25hYmxlIGF0IHRoZSBzY2hvb2wgbGV2ZWw/DQoNCjQuMi4gSXMgdGhlIG5vcm1hbGl0eSBhc3N1bXB0aW9uIHJlYXNvbmFibGUgYXQgdGhlIHB1cGlsIGxldmVsPw0KDQo0LjMuIElzIGl0IHJlYXNvbmFibGUgdG8gYXNzdW1lIGhvbW9zY2VkYXN0aWNpdHk/DQo=