nwickelmaier/lead_lmm
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add exercise and clean up code for example

Browse Source
This commit is contained in:
Nora Wickelmaier
2025-06-20 13:59:41 +02:00
parent 72bd3fcaa7
commit 40fdb67b67
6 changed files with 186 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files
code/hsb.R
+50 -32
View File
@@ -1,33 +1,49 @@
# hsb.R
#
# content: (1) Read and plot data
# (2) Fit models with random school effects
# (3) Hierarchical modeling
#
# input: data/hsbdataset.txt
# output: --
#
# last mod: 2025-06-20, NW
library(lme4)
library(lattice)
#----- (1) Read and plot data -------------------------------------------------
dat <- read.table("data/hsbdataset.txt", header = TRUE)
dat$gmmath <- mean(dat$mathach)
dat$meanmath <- with(dat, ave(mathach, school))
plot(dat$ses - dat$meanses, dat$cses)
xyplot(mathach ~ cses, dat)
xyplot(mathach + meanmath + gmmath ~ cses | factor(school), dat,
type = c("p", "r", "r"), distribute.type = TRUE,
xyplot(mathach + meanmath + gmmath ~ cses | factor(school), data = dat,
type = c("p", "r", "r"),
distribute.type = TRUE,
col = c("#91C86E", "#91C86E", "#78004B"))
xyplot(gmmath + meanmath ~ cses | factor(school), dat, type = "r")
# Shorter version
xyplot(gmmath + meanmath ~ cses | factor(school), data = dat, type = "r")
#----- (2) Fit models with random school effects ------------------------------
## Null model with school-specific random intercepts
m1 <- lmer(mathach ~ 1 + (1 | school), dat)
# Plot predictions
xyplot(mathach + predict(m1) + predict(m1, re.form = NA) ~ cses | factor(school),
dat, type = c("p", "r", "r"), distribute.type = TRUE,
data = dat,
type = c("p", "r", "r"),
distribute.type = TRUE,
col = c("#91C86E", "#91C86E", "#78004B"))
# ICC
VarCorr(m1)[[1]] / (VarCorr(m1)[[1]] + sigma(m1)^2)
sjPlot::tab_model(m1)
## Model with socioeconomic status and school-specific random intercepts
xyplot(mathach ~ cses, dat)
mean(dat$cses)
m2 <- lmer(mathach ~ cses + (1 | school), dat)
@@ -38,36 +54,41 @@ xyplot(mathach + predict(m2) + predict(m2, re.form = NA) ~ cses | factor(school)
# ICC
VarCorr(m2)[[1]] / (VarCorr(m2)[[1]] + sigma(m2)^2)
sjPlot::tab_model(m1, m2)
## Model with socioeconomic status and school-specific random slopes
m3 <- lmer(mathach ~ cses + (cses | school), dat)
xyplot(mathach + predict(m3) + predict(m3, re.form = NA) ~ cses | factor(school),
dat, type = c("p", "r", "r"), distribute.type = TRUE,
col = c("#91C86E", "#91C86E", "#78004B"))
sjPlot::tab_model(m1, m2, m3)
## Model with socioeconomic status, sector, and school-specific random slopes
m4 <- lmer(mathach ~ cses + sector + (cses | school), data = dat)
sjPlot::tab_model(m1, m2, m3, m4)
## Model with socioeconomic status, sector, interaction, and school-specific
## random slopes
m5 <- lmer(mathach ~ cses * sector + (cses | school), data = dat)
sjPlot::tab_model(m1, m2, m3, m4, m5)
xyplot(mathach ~ cses, data = dat, groups = sector, type = c("p", "r"))
#----- (3) Hierarchical modeling ----------------------------------------------
h1 <- lmer(mathach ~ meanses*cses + sector*cses + (1 + cses | school),
data = dat, REML = FALSE)
h2 <- lmer(mathach ~ meanses*cses + sector*cses + (1 | school),
data = dat, REML = FALSE)
# Likelihood-ratio test
anova(h2, h1)
pm1 <- profile(h1)
confint(pm1)
xyplot(pm1)
#densityplot(pm1)
splom(pm1, which = "theta_")
lmm.1 <- lmer(mathach ~ meanses*cses + sector*cses + (1 | school), data = dat,
REML = FALSE)
lmm.2 <- lmer(mathach ~ meanses*cses + sector*cses + (1 + cses | school),
data = dat, REML = FALSE)
## Visualization of two way interaction of `cses` and `meanses`
c <- seq(-2, 2, length = 51)
m <- seq(-1, 1, length = 26)
ndat <- expand.grid(c, m)
@@ -76,19 +97,16 @@ colnames(ndat) <- c("cses", "meanses")
ndat$sector <- factor(0, levels = c("0", "1"))
z <- matrix(predict(lmm.2, newdata=ndat, re.form=NA), 51)
z <- matrix(predict(lmm.2, newdata = ndat, re.form = NA), 51)
persp(c, m, z, theta = 40, phi = 20, col = "lightblue", ltheta = 60, shade = .9,
xlab = "cses", ylab = "meanses", zlab = "mathach", main = "Model 2")
lmm.3 <- lmer(mathach ~ meanses + sector*cses + (1 + cses | school),
data = dat, REML = FALSE)
h3 <- lmer(mathach ~ meanses + sector*cses + (1 + cses | school),
data = dat, REML = FALSE)
z <- matrix(predict(lmm.3, newdata = ndat, re.form = NA), nrow = 51)
persp(c, m, z, theta = 40, phi = 20, col = "lightblue", ltheta = 60, shade = .9,
xlab = "cses", ylab = "meanses", zlab = "mathach", main = "Model 3")
# TODO: Add profiling to show instability of parameter estimation?