title: "title_to_assignment"
format:
html:
embed-resources: true
editor: visualDay 30 - 10/30/2024
Announcements
- Rendering quarto htmls
- Assignment is due tomorrow 11:59 pm
- Projects are due November 22 (3.5 weeks)
- Send to one of your classmates for peer review
- Peer review feedback due December 2nd.
- Presentations (15 min) the week of finals.
Mixed models
- Review assumptions on the whiteboard.
- Differences between fixed versus random effects
- Methods of estimation. LSE, shrinkage.
- What process is being studied? (interest at the population-level versus at the individual-level)
- How many levels does the factor have, vs. how many did we record?
- Different types of inference we obtain.
- Methods of estimation. LSE, shrinkage.
- Criteria for fixed versus random effects.
Applied examples
library(tidyverse)Random intercept and slope
dd <- read.csv("data/student_data.csv") %>%
rownames_to_column("student_ID") %>%
pivot_longer(cols = c(G1, G2), values_to = "prev_grade", names_to = "term")dd %>%
ggplot(aes(prev_grade, G3))+
geom_point()+
facet_wrap(~school)
library(nlme)m1 <- lm(G3 ~ school + prev_grade : school, data = dd)
m2 <- lm(G3 ~ school+ prev_grade : school + student_ID , data = dd)
m3 <- lm(G3 ~ school + prev_grade : school : student_ID , data = dd)
m4 <- lme(G3 ~ prev_grade : school, random = ~ 1|student_ID, data = dd)
m5 <- lme(G3 ~ school + prev_grade : school, random = ~ 0+prev_grade|student_ID, data = dd)dd$p1 <- predict(m1, dd)
dd$p2 <- predict(m2, dd)
dd$p3 <- predict(m3, dd)
dd$p4 <- predict(m4, dd)
dd$p5 <- predict(m5, dd)
dd %>%
ggplot(aes())+
facet_wrap(~school)+
geom_point(aes(x =prev_grade, y=G3))+
geom_point(aes(x=prev_grade, y=p2, group = school), color = 'lightblue')+
geom_point(aes(x=prev_grade, y=p3, group = school), color = 'orange')+
geom_point(aes(x=prev_grade, y=p4, group = school), color = 'gold')+
geom_point(aes(x=prev_grade, y=p5, group = school), color = 'lightgreen')+
geom_point(aes(x=prev_grade, y=p1), color = 'tomato')
Designed experiments
library(agridat)data(gilmour.serpentine)
dd <- gilmour.serpentine
dd <- dd %>%
mutate(rowf=factor(row), colf=factor(10*(col-8)))
str(dd)'data.frame': 330 obs. of 7 variables:
$ col : int 1 1 1 1 1 1 1 1 1 1 ...
$ row : int 1 2 3 4 5 6 7 8 9 10 ...
$ rep : Factor w/ 3 levels "R1","R2","R3": 1 1 1 1 1 1 1 1 1 1 ...
$ gen : Factor w/ 107 levels "(WWH*MM)*WR*",..: 4 10 15 17 21 32 33 34 72 74 ...
$ yield: int 483 526 557 564 498 510 344 600 466 370 ...
$ rowf : Factor w/ 22 levels "1","2","3","4",..: 1 2 3 4 5 6 7 8 9 10 ...
$ colf : Factor w/ 15 levels "-70","-60","-50",..: 1 1 1 1 1 1 1 1 1 1 ...polygon <- data.frame(rep = rep(c("R1", "R2", "R3"), each = 4),
col = rep(c(.5, 5.5, .5, 10.5, 10.5, 15.5), each =2),
row = rep(c(.5, 22.5, 22.5, .5), 3))
dd %>%
ggplot(aes(col, row))+
geom_raster(aes(fill = yield))+
coord_equal()+
geom_polygon(aes(group = rep),
data = polygon,
fill = NA, color = 'black')+
rcartocolor::scale_fill_carto_c(palette = "Earth",
name = expression(Yield~(g~m^{-2}))) +
theme_minimal()+
labs(x = "Col",
y = "Row")
library(nlme)
m_fixed <- lm(yield ~ 0 + gen + rep, data = dd)
m_mixed <- lme(yield ~ 0 + gen,
random = ~ 1 | rep,
data = dd)
m_mixedLinear mixed-effects model fit by REML
Data: dd
Log-restricted-likelihood: -1440.145
Fixed: yield ~ 0 + gen
gen(WWH*MM)*WR* gen(WqKPWmH*3Ag genAMERY genANGAS genAROONA
709.0000 733.3333 615.6667 576.3333 555.3333
genBATAVIA genBD231 genBEULAH genBLADE genBT_SCHOMBURG
533.6667 638.6667 535.3333 439.0000 660.0000
genCADOUX genCONDOR genCORRIGIN genCUNNINGHAM genDGR/MNX-9-9e
485.6667 584.6667 491.3333 454.3333 661.3333
genDOLLARBIRD genEXCALIBUR genGOROKE genHALBERD genHOUTMAN
508.3333 654.0000 567.3333 655.6667 499.6667
genJANZ genK2011-5* genKATUNGA genKIATA genKITE
494.3333 621.6667 598.6667 543.3333 529.0000
genKULIN genLARK genLOWAN genM4997 genM5075
618.0000 372.6667 556.6667 563.0000 514.3333
genM5097 genMACHETE genMEERING genMOLINEUX genOSPREY
606.3333 477.6667 461.3333 543.3333 547.0000
genOUYEN genOXLEY genPELSART genPEROUSE genRAC655
572.3333 487.3333 508.6667 425.3333 596.3333
genRAC655'S' genRAC696 genRAC710 genRAC750 genRAC759
595.3333 705.3333 658.0000 631.6667 667.0000
genRAC772 genRAC777 genRAC779 genRAC787 genRAC791
714.0000 536.6667 712.6667 591.0000 636.3333
genRAC792 genRAC798 genRAC804 genRAC805 genRAC806
606.6667 707.3333 664.0000 666.0000 673.6667
genRAC807 genRAC808 genRAC809 genRAC810 genRAC811
617.6667 655.0000 665.6667 577.3333 751.3333
genRAC812 genRAC813 genRAC814 genRAC815 genRAC816
615.0000 625.6667 636.6667 598.0000 642.6667
genRAC817 genRAC818 genRAC819 genRAC820 genRAC821
609.0000 602.0000 587.6667 708.0000 610.6667
genROSELLA genSCHOMBURGK genSHRIKE genSPEAR genSTILETTO
524.6667 576.6667 581.0000 454.3333 552.0000
genSUNBRI genSUNFIELD genSUNLAND genSWIFT genTASMAN
490.6667 502.3333 526.3333 512.0000 548.0000
genTATIARA genTINCURRIN genTRIDENT genVF299 genVF300
644.6667 690.0000 576.3333 642.6667 597.3333
genVF302 genVF508 genVF519 genVF655 genVF664
600.6667 720.6667 708.0000 548.8333 602.3333
genVG127 genVG503 genVG506 genVG701 genVG714
599.3333 666.0000 600.3333 689.6667 600.6667
genVG878 genWARBLER genWI216 genWI221 genWI231
761.3333 492.0000 713.0000 691.6667 490.6667
genWI232 genWILGOYNE genWW1402 genWW1477 genWW1831
652.6667 578.0000 591.6667 523.3333 622.3333
genWYUNA genYARRALINKA
532.3333 464.0000
Random effects:
Formula: ~1 | rep
(Intercept) Residual
StdDev: 112.8552 115.5814
Number of Observations: 330
Number of Groups: 3 Hierarchical models
- Further interpretations of (nested) random effects.
Coming next
- Assignment is due tomorrow 11:59 pm
- Projects are due November 22 (3.5 weeks)
- Send to one of your classmates for peer review
- Peer review feedback due December 2nd.
- Presentations (15 min) the week of finals.