Simple graphs illustrating regression for causal inference. See Chapter 1 in Regression and Other Stories.
The simulated data depends on the random seed, and thus the plots and numbers here and in the book may differ. You can experiment with the simulation variation by changing the seed.
Load packages
library("rprojroot")
root<-has_file(".ROS-Examples-root")$make_fix_file()
library("arm")
# for reproducibility of simulated data
SEED <- 1151
Simulated data from linear model
set.seed(SEED)
N <- 50
x <- runif(N, 1, 5)
y <- rnorm(N, 10 + 3*x, 3)
x_binary <- ifelse(x<3, 0, 1)
data <- data.frame(N, x, y, x_binary)
Regression with binary predictor
lm_1a <- lm(y ~ x_binary, data = data)
display(lm_1a)
lm(formula = y ~ x_binary, data = data)
coef.est coef.se
(Intercept) 16.20 0.65
x_binary 4.63 0.95
---
n = 50, k = 2
residual sd = 3.36, R-Squared = 0.33
Plots
par(mar=c(3, 3, 1.5, 1), mgp=c(1.7, .5, 0), tck=-.01)
plot(x_binary, y, xlab="", ylab="Outcome measurement", pch=20, cex=.5, bty="l", main="Regression with binary treatment", cex.main=.9, xaxt="n", cex.lab=.9, cex.axis=.9)
axis(1, c(0,1), c(" Control", "Treatment "), cex.axis=.9)
abline(coef(lm_1a)[1], coef(lm_1a)[2])
text(0.3, 13, paste("Estimated treatment effect is\nslope of fitted line: ", fround(coef(lm_1a)[2], 1)), cex=.8, adj=0)
Regression with continuous predictor
lm_1b <- lm(y ~ x, data = data)
display(lm_1b)
lm(formula = y ~ x, data = data)
coef.est coef.se
(Intercept) 10.08 1.13
x 2.89 0.37
---
n = 50, k = 2
residual sd = 2.73, R-Squared = 0.56
par(mar=c(3, 3, 1.5, 1), mgp=c(1.7, .5, 0), tck=-.01)
plot(x, y, xlab="Treatment level", ylab="Outcome measurement", pch=20, cex=.5, bty="l", main="Regression with continuous treatment", cex.main=.9, cex.lab=.9, cex.axis=.9)
abline(coef(lm_1b)[1], coef(lm_1b)[2])
text(3.2, 15, paste("Estimated treatment\neffect per unit of x is\nslope of fitted line: ", fround(coef(lm_1b)[2], 1)), cex=.8, adj=0)
Simulated data from nonlinear model
set.seed(SEED)
y <- rnorm(N, 5 + 30*exp(-x), 2)
data$y <- y
Classical regression with continuous predictor
lm_2a <- lm(y ~ x, data = data)
display(lm_2a)
lm(formula = y ~ x, data = data)
coef.est coef.se
(Intercept) 13.37 0.74
x -2.18 0.24
---
n = 50, k = 2
residual sd = 1.78, R-Squared = 0.63
par(mar=c(3, 3, 1.5, 1), mgp=c(1.7, .5, 0), tck=-.01)
plot(x, y, xlab="Treatment level", ylab="Outcome measurement", pch=20, cex=.5, bty="l", main="Nonlinear treatment effect", cex.main=.9, cex.lab=.9, cex.axis=.9)
curve(5 + 30*exp(-x), add=TRUE)
par(mar=c(3, 3, 1.5, 1), mgp=c(1.7, .5, 0), tck=-.01)
plot(x, y, xlab="Treatment level", ylab="Outcome measurement", pch=20, cex=.5, bty="l", main="Nonlinear effect, estimated with straight line fit", cex.main=.9, cex.lab=.9, cex.axis=.9)
abline(coef(lm_2a)[1], coef(lm_2a)[2])
Simulated data from two groups
set.seed(SEED)
N <- 100
z <- rep(0:1, N/2)
xx <- ifelse(z==0, rnorm(N, 0, 1.2)^2, rnorm(N, 0, .8)^2)
yy <- rnorm(N, 20 + 5*xx + 10*z, 3)
data <- data.frame(xx, z, yy)
lm_2 <- lm(yy ~ xx + z, data=data)
display(lm_2)
lm(formula = yy ~ xx + z, data = data)
coef.est coef.se
(Intercept) 20.33 0.48
xx 5.05 0.22
z 9.83 0.59
---
n = 100, k = 3
residual sd = 2.90, R-Squared = 0.87
par(mar=c(3, 3, 1.5, 1), mgp=c(1.7, .5, 0), tck=-.01)
plot(xx, yy, xlab="Pre-treatment predictor", ylab="Outcome measurement", bty="l", main="Continuous pre-treatment predictor and binary treatment ", cex.main=.9, cex.lab=.9, cex.axis=.9, type="n")
points(xx[z==0], yy[z==0], pch=20, cex=.5)
points(xx[z==1], yy[z==1], pch=1, cex=1)
abline(coef(lm_2)[1], coef(lm_2)[2])
abline(coef(lm_2)[1] + coef(lm_2)[3], coef(lm_2)[2])
text(2.3, 29.5, "Controls", cex=.9, adj=0)
text(1.5, 45, "Treated", cex=.9, adj=0)
x0 <- 5.2
arrows(x0, coef(lm_2)[1] + coef(lm_2)[2]*x0, x0, coef(lm_2)[1] + coef(lm_2)[2]*x0 + coef(lm_2)[3], length=.1, code=3)
text(x0+.15, 1 + coef(lm_2)[1] + coef(lm_2)[2]*x0 + .5*coef(lm_2)[3], paste("Estimated\ntreatment\neffect is", fround(coef(lm_2)[3], 1)), cex=.8, adj=0)
LS0tCnRpdGxlOiAiUmVncmVzc2lvbiBhbmQgT3RoZXIgU3RvcmllczogU2ltcGxlQ2F1c2FsIgphdXRob3I6ICJBbmRyZXcgR2VsbWFuLCBKZW5uaWZlciBIaWxsLCBBa2kgVmVodGFyaSIKZGF0ZTogImByIGZvcm1hdChTeXMuRGF0ZSgpKWAiCm91dHB1dDoKICBodG1sX2RvY3VtZW50OgogICAgdGhlbWU6IHJlYWRhYmxlCiAgICB0b2M6IHRydWUKICAgIHRvY19kZXB0aDogMgogICAgdG9jX2Zsb2F0OiB0cnVlCiAgICBjb2RlX2Rvd25sb2FkOiB0cnVlCi0tLQpTaW1wbGUgZ3JhcGhzIGlsbHVzdHJhdGluZyByZWdyZXNzaW9uIGZvciBjYXVzYWwgaW5mZXJlbmNlLiBTZWUKQ2hhcHRlciAxIGluIFJlZ3Jlc3Npb24gYW5kIE90aGVyIFN0b3JpZXMuCgpUaGUgc2ltdWxhdGVkIGRhdGEgZGVwZW5kcyBvbiB0aGUgcmFuZG9tIHNlZWQsIGFuZCB0aHVzIHRoZSBwbG90cwphbmQgbnVtYmVycyBoZXJlIGFuZCBpbiB0aGUgYm9vayBtYXkgZGlmZmVyLiBZb3UgY2FuIGV4cGVyaW1lbnQKd2l0aCB0aGUgc2ltdWxhdGlvbiB2YXJpYXRpb24gYnkgY2hhbmdpbmcgdGhlIHNlZWQuCgotLS0tLS0tLS0tLS0tCgoKYGBge3Igc2V0dXAsIGluY2x1ZGU9RkFMU0V9CmtuaXRyOjpvcHRzX2NodW5rJHNldChtZXNzYWdlPUZBTFNFLCBlcnJvcj1GQUxTRSwgd2FybmluZz1GQUxTRSwgY29tbWVudD1OQSkKIyBzd2l0Y2ggdGhpcyB0byBUUlVFIHRvIHNhdmUgZmlndXJlcyBpbiBzZXBhcmF0ZSBmaWxlcwpzYXZlZmlncyA8LSBGQUxTRQpgYGAKCiMjIyMgTG9hZCBwYWNrYWdlcwoKYGBge3IgfQpsaWJyYXJ5KCJycHJvanJvb3QiKQpyb290PC1oYXNfZmlsZSgiLlJPUy1FeGFtcGxlcy1yb290IikkbWFrZV9maXhfZmlsZSgpCmxpYnJhcnkoImFybSIpCiMgZm9yIHJlcHJvZHVjaWJpbGl0eSBvZiBzaW11bGF0ZWQgZGF0YQpTRUVEIDwtIDExNTEKYGBgCgojIyBTaW11bGF0ZWQgZGF0YSBmcm9tIGxpbmVhciBtb2RlbAoKYGBge3IgfQpzZXQuc2VlZChTRUVEKQpOIDwtIDUwCnggPC0gcnVuaWYoTiwgMSwgNSkKeSA8LSBybm9ybShOLCAxMCArIDMqeCwgMykKeF9iaW5hcnkgPC0gaWZlbHNlKHg8MywgMCwgMSkKZGF0YSA8LSBkYXRhLmZyYW1lKE4sIHgsIHksIHhfYmluYXJ5KQpgYGAKCiMjIyMgUmVncmVzc2lvbiB3aXRoIGJpbmFyeSBwcmVkaWN0b3IKCmBgYHtyIH0KbG1fMWEgPC0gbG0oeSB+IHhfYmluYXJ5LCBkYXRhID0gZGF0YSkKZGlzcGxheShsbV8xYSkKYGBgCgojIyMjIFBsb3RzCgpgYGB7ciBldmFsPUZBTFNFLCBpbmNsdWRlPUZBTFNFfQppZiAoc2F2ZWZpZ3MpIHBkZihyb290KCJTaW1wbGVDYXVzYWwvZmlncyIsIm92ZXJ2aWV3XzFhLnBkZiIpLCBoZWlnaHQ9My41LCB3aWR0aD00LjUpCmBgYApgYGB7ciB9CnBhcihtYXI9YygzLCAzLCAxLjUsIDEpLCBtZ3A9YygxLjcsIC41LCAwKSwgdGNrPS0uMDEpCnBsb3QoeF9iaW5hcnksIHksIHhsYWI9IiIsIHlsYWI9Ik91dGNvbWUgbWVhc3VyZW1lbnQiLCBwY2g9MjAsIGNleD0uNSwgYnR5PSJsIiwgbWFpbj0iUmVncmVzc2lvbiB3aXRoIGJpbmFyeSB0cmVhdG1lbnQiLCBjZXgubWFpbj0uOSwgeGF4dD0ibiIsIGNleC5sYWI9LjksIGNleC5heGlzPS45KQpheGlzKDEsIGMoMCwxKSwgYygiICAgIENvbnRyb2wiLCAiVHJlYXRtZW50ICAgICIpLCBjZXguYXhpcz0uOSkKYWJsaW5lKGNvZWYobG1fMWEpWzFdLCBjb2VmKGxtXzFhKVsyXSkKdGV4dCgwLjMsIDEzLCBwYXN0ZSgiRXN0aW1hdGVkIHRyZWF0bWVudCBlZmZlY3QgaXNcbnNsb3BlIG9mIGZpdHRlZCBsaW5lOiAiLCBmcm91bmQoY29lZihsbV8xYSlbMl0sIDEpKSwgY2V4PS44LCBhZGo9MCkKYGBgCmBgYHtyIGV2YWw9RkFMU0UsIGluY2x1ZGU9RkFMU0V9CmlmIChzYXZlZmlncykgZGV2Lm9mZigpCmBgYAoKIyMjIyBSZWdyZXNzaW9uIHdpdGggY29udGludW91cyBwcmVkaWN0b3IKCmBgYHtyIH0KbG1fMWIgPC0gbG0oeSB+IHgsIGRhdGEgPSBkYXRhKQpkaXNwbGF5KGxtXzFiKQoKYGBgCmBgYHtyIGV2YWw9RkFMU0UsIGluY2x1ZGU9RkFMU0V9CmlmIChzYXZlZmlncykgcGRmKHJvb3QoIlNpbXBsZUNhdXNhbC9maWdzIiwib3ZlcnZpZXdfMWIucGRmIiksIGhlaWdodD0zLjUsIHdpZHRoPTQuNSkKYGBgCmBgYHtyIH0KcGFyKG1hcj1jKDMsIDMsIDEuNSwgMSksIG1ncD1jKDEuNywgLjUsIDApLCB0Y2s9LS4wMSkKcGxvdCh4LCB5LCB4bGFiPSJUcmVhdG1lbnQgbGV2ZWwiLCB5bGFiPSJPdXRjb21lIG1lYXN1cmVtZW50IiwgcGNoPTIwLCBjZXg9LjUsIGJ0eT0ibCIsIG1haW49IlJlZ3Jlc3Npb24gd2l0aCBjb250aW51b3VzIHRyZWF0bWVudCIsIGNleC5tYWluPS45LCBjZXgubGFiPS45LCBjZXguYXhpcz0uOSkKYWJsaW5lKGNvZWYobG1fMWIpWzFdLCBjb2VmKGxtXzFiKVsyXSkKdGV4dCgzLjIsIDE1LCBwYXN0ZSgiRXN0aW1hdGVkIHRyZWF0bWVudFxuZWZmZWN0IHBlciB1bml0IG9mIHggaXNcbnNsb3BlIG9mIGZpdHRlZCBsaW5lOiAiLCBmcm91bmQoY29lZihsbV8xYilbMl0sIDEpKSwgY2V4PS44LCBhZGo9MCkKYGBgCmBgYHtyIGV2YWw9RkFMU0UsIGluY2x1ZGU9RkFMU0V9CmlmIChzYXZlZmlncykgZGV2Lm9mZigpCmBgYAoKIyMgU2ltdWxhdGVkIGRhdGEgZnJvbSBub25saW5lYXIgbW9kZWwKCmBgYHtyIH0Kc2V0LnNlZWQoU0VFRCkKeSA8LSBybm9ybShOLCA1ICsgMzAqZXhwKC14KSwgMikKZGF0YSR5IDwtIHkKYGBgCgojIyMjIENsYXNzaWNhbCByZWdyZXNzaW9uIHdpdGggY29udGludW91cyBwcmVkaWN0b3IKCmBgYHtyIH0KbG1fMmEgPC0gbG0oeSB+IHgsIGRhdGEgPSBkYXRhKQpkaXNwbGF5KGxtXzJhKQoKYGBgCmBgYHtyIGV2YWw9RkFMU0UsIGluY2x1ZGU9RkFMU0V9CmlmIChzYXZlZmlncykgcGRmKHJvb3QoIlNpbXBsZUNhdXNhbC9maWdzIiwib3ZlcnZpZXdfMmEucGRmIiksIGhlaWdodD0zLjUsIHdpZHRoPTQuNSkKYGBgCmBgYHtyIH0KcGFyKG1hcj1jKDMsIDMsIDEuNSwgMSksIG1ncD1jKDEuNywgLjUsIDApLCB0Y2s9LS4wMSkKcGxvdCh4LCB5LCB4bGFiPSJUcmVhdG1lbnQgbGV2ZWwiLCB5bGFiPSJPdXRjb21lIG1lYXN1cmVtZW50IiwgcGNoPTIwLCBjZXg9LjUsIGJ0eT0ibCIsIG1haW49Ik5vbmxpbmVhciB0cmVhdG1lbnQgZWZmZWN0IiwgY2V4Lm1haW49LjksIGNleC5sYWI9LjksIGNleC5heGlzPS45KQpjdXJ2ZSg1ICsgMzAqZXhwKC14KSwgYWRkPVRSVUUpCmBgYApgYGB7ciBldmFsPUZBTFNFLCBpbmNsdWRlPUZBTFNFfQppZiAoc2F2ZWZpZ3MpIGRldi5vZmYoKQoKYGBgCmBgYHtyIGV2YWw9RkFMU0UsIGluY2x1ZGU9RkFMU0V9CmlmIChzYXZlZmlncykgcGRmKHJvb3QoIlNpbXBsZUNhdXNhbC9maWdzIiwib3ZlcnZpZXdfMmIucGRmIiksIGhlaWdodD0zLjUsIHdpZHRoPTQuNSkKYGBgCmBgYHtyIH0KcGFyKG1hcj1jKDMsIDMsIDEuNSwgMSksIG1ncD1jKDEuNywgLjUsIDApLCB0Y2s9LS4wMSkKcGxvdCh4LCB5LCB4bGFiPSJUcmVhdG1lbnQgbGV2ZWwiLCB5bGFiPSJPdXRjb21lIG1lYXN1cmVtZW50IiwgcGNoPTIwLCBjZXg9LjUsIGJ0eT0ibCIsIG1haW49Ik5vbmxpbmVhciBlZmZlY3QsIGVzdGltYXRlZCB3aXRoIHN0cmFpZ2h0IGxpbmUgZml0IiwgY2V4Lm1haW49LjksIGNleC5sYWI9LjksIGNleC5heGlzPS45KQphYmxpbmUoY29lZihsbV8yYSlbMV0sIGNvZWYobG1fMmEpWzJdKQpgYGAKYGBge3IgZXZhbD1GQUxTRSwgaW5jbHVkZT1GQUxTRX0KaWYgKHNhdmVmaWdzKSBkZXYub2ZmKCkKYGBgCgojIyBTaW11bGF0ZWQgZGF0YSBmcm9tIHR3byBncm91cHMKCmBgYHtyIH0Kc2V0LnNlZWQoU0VFRCkKTiA8LSAxMDAKeiA8LSByZXAoMDoxLCBOLzIpCnh4IDwtIGlmZWxzZSh6PT0wLCBybm9ybShOLCAwLCAxLjIpXjIsIHJub3JtKE4sIDAsIC44KV4yKQp5eSA8LSBybm9ybShOLCAyMCArIDUqeHggKyAxMCp6LCAzKQpkYXRhIDwtIGRhdGEuZnJhbWUoeHgsIHosIHl5KQpsbV8yIDwtIGxtKHl5IH4geHggKyB6LCBkYXRhPWRhdGEpCmRpc3BsYXkobG1fMikKCmBgYApgYGB7ciBldmFsPUZBTFNFLCBpbmNsdWRlPUZBTFNFfQppZiAoc2F2ZWZpZ3MpIHBkZihyb290KCJTaW1wbGVDYXVzYWwvZmlncyIsIm92ZXJ2aWV3XzMucGRmIiksIGhlaWdodD0zLjUsIHdpZHRoPTQuNSkKYGBgCmBgYHtyIH0KcGFyKG1hcj1jKDMsIDMsIDEuNSwgMSksIG1ncD1jKDEuNywgLjUsIDApLCB0Y2s9LS4wMSkKcGxvdCh4eCwgeXksIHhsYWI9IlByZS10cmVhdG1lbnQgcHJlZGljdG9yIiwgeWxhYj0iT3V0Y29tZSBtZWFzdXJlbWVudCIsIGJ0eT0ibCIsIG1haW49IkNvbnRpbnVvdXMgcHJlLXRyZWF0bWVudCBwcmVkaWN0b3IgYW5kIGJpbmFyeSB0cmVhdG1lbnQgICAgIiwgY2V4Lm1haW49LjksIGNleC5sYWI9LjksIGNleC5heGlzPS45LCB0eXBlPSJuIikKcG9pbnRzKHh4W3o9PTBdLCB5eVt6PT0wXSwgcGNoPTIwLCBjZXg9LjUpCnBvaW50cyh4eFt6PT0xXSwgeXlbej09MV0sIHBjaD0xLCBjZXg9MSkKYWJsaW5lKGNvZWYobG1fMilbMV0sIGNvZWYobG1fMilbMl0pCmFibGluZShjb2VmKGxtXzIpWzFdICsgY29lZihsbV8yKVszXSwgY29lZihsbV8yKVsyXSkKdGV4dCgyLjMsIDI5LjUsICJDb250cm9scyIsIGNleD0uOSwgYWRqPTApCnRleHQoMS41LCA0NSwgIlRyZWF0ZWQiLCBjZXg9LjksIGFkaj0wKQp4MCA8LSA1LjIKYXJyb3dzKHgwLCBjb2VmKGxtXzIpWzFdICsgY29lZihsbV8yKVsyXSp4MCwgeDAsIGNvZWYobG1fMilbMV0gKyBjb2VmKGxtXzIpWzJdKngwICsgY29lZihsbV8yKVszXSwgbGVuZ3RoPS4xLCBjb2RlPTMpCnRleHQoeDArLjE1LCAxICsgY29lZihsbV8yKVsxXSArIGNvZWYobG1fMilbMl0qeDAgKyAuNSpjb2VmKGxtXzIpWzNdLCBwYXN0ZSgiRXN0aW1hdGVkXG50cmVhdG1lbnRcbmVmZmVjdCBpcyIsIGZyb3VuZChjb2VmKGxtXzIpWzNdLCAxKSksIGNleD0uOCwgYWRqPTApCmBgYApgYGB7ciBldmFsPUZBTFNFLCBpbmNsdWRlPUZBTFNFfQppZiAoc2F2ZWZpZ3MpIGRldi5vZmYoKQoKZm9yIChqIGluIDA6MSkgcHJpbnQobWVhbih5eVt6PT1qXSkpCmZvciAoaiBpbiAwOjEpIHByaW50KG1lYW4oeHhbej09al0pKQpgYGAKCg==