One thing we could do, is draw a straight line through this scatterplot, like so: ```{r} plot(dist ~ speed, data = cars, xlab = "Speed (in Miles Per Hour)", ylab = "Stopping Distance (in Feet)", main = "Stopping Distance vs Speed", pch = 20, cex = 2, col = "red") abline(a = 60,b = 0,lw=3) ``` Now that doesn't seem a particularly *good* way to summarize the relationship. Clearly, a *better* line would be not be flat, but have a *slope*, i.e. go upwards: ```{r,echo=FALSE} plot(dist ~ speed, data = cars, xlab = "Speed (in Miles Per Hour)", ylab = "Stopping Distance (in Feet)", main = "Stopping Distance vs Speed", pch = 20, cex = 2, col = "red") abline(a = 0,b = 5,lw=3) ``` That is slightly better. However, the line seems at too high a level - the point at which it crosses the y-axis is called the *intercept*; and it's too high. We just learned how to represent a *line*, i.e. with two numbers called *intercept* and *slope*. Let's write down a simple formula which represents a line where some outcome $z$ is related to a variable $x$: \begin{equation} z = b_0 + b_1 x (\#eq:bline) \end{equation} Here $b_0$ represents the value of the intercept (i.e. $z$ when $x=0$), and $b_1$ is the value of the slope. The question for us is now: How to choose the number $b_0$ and $b_1$ such that the result is the **good** line? ### Choosing the Best Line ```{r, echo = FALSE, message = FALSE, warning = FALSE} generate_data = function(int = 0.5, slope = 1, sigma = 10, n_obs = 9, x_min = 0, x_max = 10) { x = seq(x_min, x_max, length.out = n_obs) y = int + slope * x + rnorm(n_obs, 0, sigma) fit = lm(y ~ x) y_hat = fitted(fit) y_bar = rep(mean(y), n_obs) error = resid(fit) meandev = y - y_bar data.frame(x, y, y_hat, y_bar, error, meandev) } plot_total_dev = function(reg_data,title=NULL) { if (is.null(title)){ plot(reg_data$x, reg_data$y, xlab = "x", ylab = "y", pch = 20, cex = 2, col = "grey") rect(xleft = reg_data$x, ybottom = reg_data$y, xright = reg_data$x + abs(reg_data$meandev), ytop = reg_data$y - reg_data$meandev, density = -1, col = rgb(red = 0, green = 0, blue = 1, alpha = 0.5), border = NA) } else { plot(reg_data$x, reg_data$y, xlab = "x", ylab = "y", pch = 20, cex = 2, col = "grey",main=title,ylim=c(-2,10.5)) axis(side=2,at=seq(-2,10,by=2)) rect(xleft = reg_data$x, ybottom = reg_data$y, xright = reg_data$x + abs(reg_data$meandev), ytop = reg_data$y - reg_data$meandev, density = -1, col = rgb(red = 0, green = 0, blue = 1, alpha = 0.5), border = NA) } # arrows(reg_data$x, reg_data$y_bar, # reg_data$x, reg_data$y, # col = 'grey', lwd = 1, lty = 3, length = 0.2, angle = 20) abline(h = mean(reg_data$y), lwd = 2,col = "grey") # abline(lm(y ~ x, data = reg_data), lwd = 2, col = "grey") } plot_total_dev_prop = function(reg_data) { plot(reg_data$x, reg_data$y, xlab = "x", ylab = "y", pch = 20, cex = 2, col = "grey") arrows(reg_data$x, reg_data$y_bar, reg_data$x, reg_data$y_hat, col = 'darkorange', lwd = 1, length = 0.2, angle = 20) arrows(reg_data$x, reg_data$y_hat, reg_data$x, reg_data$y, col = 'dodgerblue', lwd = 1, lty = 2, length = 0.2, angle = 20) abline(h = mean(reg_data$y), lwd = 2,col = "grey") abline(lm(y ~ x, data = reg_data), lwd = 2, col = "grey") } plot_unexp_dev = function(reg_data) { plot(reg_data$x, reg_data$y, xlab = "x", ylab = "y", pch = 20, cex = 2,asp=1) arrows(reg_data$x, reg_data$y_hat, reg_data$x, reg_data$y, col = 'red', lwd = 2, lty = 1, length = 0.1, angle = 20) abline(lm(y ~ x, data = reg_data), lwd = 2, col = "black") } plot_unexp_SSR = function(reg_data,asp=1,title=NULL) { if (is.null(title)){ plot(reg_data$x, reg_data$y, xlab = "x", ylab = "y", pch = 20, cex = 2, rect(xleft = reg_data$x, ybottom = reg_data$y, xright = reg_data$x + abs(reg_data$error), ytop = reg_data$y - reg_data$error, density = -1, col = rgb(red = 1, green = 0, blue = 0, alpha = 0.5), border = NA),asp=asp) abline(lm(y ~ x, data = reg_data), lwd = 2, col = "black") } else { plot(reg_data$x, reg_data$y, xlab = "x", ylab = "y", pch = 20, cex = 2, rect(xleft = reg_data$x, ybottom = reg_data$y, xright = reg_data$x + abs(reg_data$error), ytop = reg_data$y - reg_data$error, density = -1, col = rgb(red = 1, green = 0, blue = 0, alpha = 0.5), border = NA),asp=asp,main=title) axis(side=2,at=seq(-2,10,by=2)) abline(lm(y ~ x, data = reg_data), lwd = 2, col = "black") } } plot_exp_dev = function(reg_data) { plot(reg_data$x, reg_data$y, main = "SSReg (Sum of Squares Regression)", xlab = "x", ylab = "y", pch = 20, cex = 2, col = "grey") arrows(reg_data$x, reg_data$y_bar, reg_data$x, reg_data$y_hat, col = 'darkorange', lwd = 1, length = 0.2, angle = 20) abline(lm(y ~ x, data = reg_data), lwd = 2, col = "grey") abline(h = mean(reg_data$y), col = "grey") } ``` ```{r, echo=FALSE, message=FALSE, warning=FALSE} set.seed(21) plot_data = generate_data(sigma = 2) ``` In order to be able to reason about good or bad line, we need to denote the *output* of equation \@ref(eq:bline). We call the value $\hat{y}_i$ the *predicted value* for obseration $i$, after having chosen some particular values $b_0$ and $b_1$: \begin{equation} \hat{y}_i = b_0 + b_1 x_i (\#eq:abline-pred) \end{equation} In general it is likely that we won't be able to choose $b_0$ and $b_1$ in such as way as to provide a perfect prediction, i.e. one where $\hat{y}_i = y_i$ for all $i$. That is, we expect to make an *error* in our prediction $\hat{y}_i$, so let's denote this value $e_i$. If we acknowlegdge that we will make errors, let's at least make them as small as possible! Exactly this is going to be our task now. Suppose we have the following set of `r nrow(plot_data)` observations on `x` and `y`, and we put the *best* straight line into it, that we can think of. It would look like this: ```{r line-arrows, echo=FALSE, message=FALSE, warning=FALSE, fig.cap="The best line and its errors",fig.align="center"} plot_unexp_dev(plot_data) ``` Here, the red arrows indicate the **distance** between the prediction (i.e. the black line) to each data point, in other words, each arrow is a particular $e_i$. An upward pointing arrow indicates a positive value of a particular $e_i$, and vice versa for downward pointing arrows. The erros are also called *residuals*, which comes from the way can write the equation for this relationship between two particular values $(y_i,x_i)$ belonging to observation $i$: \begin{equation} y_i = b_0 + b_1 x_i + e_i (\#eq:abline) \end{equation} You realize of course that $\hat{y}_i = y_i - e_i$, which just means that our prediction is the observed value $y_i$ minus any error $e_i$ we make. In other words, $e_i$ is what is left to be explained on top of the line $b_0 + b_1 x_i$, hence, it's a residual to explain $y_i$. Here are $y,\hat{y}$ and the resulting $e$ which are plotted in figure \@ref(fig:line-arrows): ```{r,echo=FALSE} knitr:::kable(subset(plot_data,select=c(x,y,y_hat,error)),align = "c",digits = 2) ``` If our line was a **perfect fit** to the data, all $e_i = 0$, and the column `error` would display `0` for each row - there would be no errors at all. (All points in figure \@ref(fig:line-arrows) would perfectly line up on a straight line). Now, back to our claim that this particular line is the *best* line. What exactly characterizes this best line? We now come back to what we said above - *how to make the errors as small as possible*? Keeping in mind that each residual $e_i$ is $y_i - \hat{y}_i$, we have the following minization problem to solve: \begin{align} e_i & = y_i - \hat{y}_i = y_i - \underbrace{\left(b_0 + b_1 x_i\right)}_\text{prediction}\\ e_1^2 + \dots + e_N^2 &= \sum_{i=1}^N e_i^2 \equiv \text{SSR}(b_0,b_1) \\ (b_0,b_1) &= \arg \min_{\text{int},\text{slope}} \sum_{i=1}^N \left[y_i - \left(\text{int} + \text{slope } x_i\right)\right]^2 (\#eq:ols-min) \end{align} ```{block,type="warning"} The best line chooses $b_0$ and $b_1$ so as to minimize the sum of **squared residuals** (SSR). ```
Wait a moment, why *squared* residuals? This is easy to understand: suppose that instead, we wanted to just make the *sum* of the arrows in figure \@ref(fig:line-arrows) as small as possible (that is, no squares). Choosing our line to make this number small would not give a particularly good representation of the data -- given that errors of opposite sign and equal magnitude offset, we could have very long arrows (but of opposite signs), and a poor resulting line. Squaring each error avoids this (because now negative errors get positive values!) ```{r line-squares, echo=FALSE, message=FALSE, warning=FALSE, fig.align='center', fig.cap="The best line and its SQUARED errors"} plot_unexp_SSR(plot_data) ``` We illustrate this in figure \@ref(fig:line-squares). This is the same data as in figure \@ref(fig:line-arrows), but instead of arrows of length $e_i$ for each observation $i$, now we draw a square with side $e_i$, i.e. an area of $e_i^2$. We have two apps for you at this point, one where you have to try and find the best line by choosing $b_0$ and $b_1$, only focusing on the sum of errors (and not their square), and a second one focusing on squared errors: ```{r app1, eval=FALSE} library(ScPoApps) launchApp("reg_simple_arrows") launchApp("reg_simple") # with squared errors launchApp("SSR_cone") # visualize the minimzation problem from above! ``` Most of our `apps` have an associated `about` document, which gives extra information and explanations. After you have looked at all three apps, we invite you thus to have a look at the associated explainers by typing ```{r,eval=FALSE} aboutApp("reg_simple_arrows") aboutApp("reg_simple") aboutApp("SSR_cone") ``` ## Ordinary Least Squares (OLS) Estimator{#OLS} The method to compute (or *estimate*) $b_0$ and $b_1$ we illustrated above is called *Ordinary Least Squares*, or OLS. $b_0$ and $b_1$ are therefore also often called the *OLS coefficients*. By solving problem \@ref(eq:ols-min) one can derive an explicit formula for them: \begin{equation} b_1 = \frac{cov(x,y)}{var(x)}, (\#eq:beta1hat) \end{equation} i.e. the estimate of the slope coefficient is the covariance between $x$ and $y$ divided by the variance of $x$, both computed from our sample of data. With $b_1$ in hand, we can get the estimate for the intercept as \begin{equation} b_0 = \bar{y} - b_1 \bar{x}. (\#eq:beta0hat) \end{equation} where $\bar{z}$ denotes the sample mean of variable $z$. The interpretation of the OLS slope coefficient $b_1$ is as follows. Given a line as in $y = b_0 + b_1 x$, * $b_1 = \frac{d y}{d x}$ measures the change in $y$ resulting from a one unit change in $x$ * For example, if $y$ is wage and $x$ is years of education, $b_1$ would measure the effect of an additional year of education on wages. There is an alternative representation for the OLS slope coefficient which relates to the *correlation coefficient* $r$. Remember from section \@ref(summarize-two) that $r = \frac{cov(x,y)}{s_x s_y}$, where $s_z$ is the standard deviation of variable $z$. With this in hand, we can derive the OLS slope coefficient as \begin{align} b_1 &= \frac{cov(x,y)}{var(x)}\\ &= \frac{cov(x,y)}{s_x s_x} \\ &= r\frac{s_y}{s_x} (\#eq:beta1-r) \end{align} In other words, the slope coefficient is equal to the correlation coefficient $r$ times the ratio of standard deviations of $y$ and $x$. ### Linear Regression without Regressor There are several important special cases for the linear regression introduced above. Let's start with the most obvious one: What is the meaning of running a regression *without any regressor*, i.e. without a $x$? Our line becomes very simple. Instead of \@ref(eq:bline), we get \begin{equation} y = b_0. (\#eq:b0line) \end{equation} This means that our minization problem in \@ref(eq:ols-min) *also* becomes very simple: We only have to choose $b_0$! We have $$ b_0 = \arg\min_{\text{int}} \sum_{i=1}^N \left[y_i - \text{int}\right]^2, $$ which is a quadratic equation with a unique optimum such that $$ b_0 = \frac{1}{N} \sum_{i=1}^N y_i = \overline{y}. $$ ```{block type='tip'} Least Squares **without regressor** $x$ estimates the sample mean of the outcome variable $y$, i.e. it produces $\overline{y}$. ``` ### Regression without an Intercept We follow the same logic here, just that we miss another bit from our initial equation and the minimisation problem in \@ref(eq:ols-min) now becomes: \begin{align} b_1 &= \arg\min_{\text{slope}} \sum_{i=1}^N \left[y_i - \text{slope } x_i \right]^2\\ \mapsto b_1 &= \frac{\frac{1}{N}\sum_{i=1}^N x_i y_i}{\frac{1}{N}\sum_{i=1}^N x_i^2} = \frac{\bar{x} \bar{y}}{\overline{x^2}} (\#eq:b1line) \end{align} ```{block type='tip'} Least Squares **without intercept** (i.e. with $b_0=0$) is a line that passes through the origin. ```
In this case we only get to choose the slope $b_1$ of this anchored line.^[ This slope is related to the angle between vectors $\mathbf{a} = (\overline{x},\overline{y})$, and $\mathbf{b} = (\overline{x},0)$. Hence, it's related to the [scalar projection](https://en.wikipedia.org/wiki/Scalar_projection) of $\mathbf{a}$ on $\mathbf{b}$.] You should now try out both of those restrictions on our linear model by spending some time with ```{r,eval=FALSE} launchApp("reg_constrained") ``` ### Centering A Regression By *centering* or *demeaning* a regression, we mean to substract from both $y$ and $x$ their respective averages to obtain $\tilde{y}_i = y_i - \bar{y}$ and $\tilde{x}_i = x_i - \bar{x}$. We then run a regression *without intercept* as above. That is, we use $\tilde{x}_i,\tilde{y}_i$ instead of $x_i,y_i$ in \@ref(eq:b1line) to obtain our slope estimate $b_1$: \begin{align} b_1 &= \frac{\frac{1}{N}\sum_{i=1}^N \tilde{x}_i \tilde{y}_i}{\frac{1}{N}\sum_{i=1}^N \tilde{x}_i^2}\\ &= \frac{\frac{1}{N}\sum_{i=1}^N (x_i - \bar{x}) (y_i - \bar{y})}{\frac{1}{N}\sum_{i=1}^N (x_i - \bar{x})^2} \\ &= \frac{cov(x,y)}{var(x)} (\#eq:bline-centered) \end{align} This last expression is *identical* to the one in \@ref(eq:beta1hat)! It's the standard OLS estimate for the slope coefficient. We note the following: ```{block type='tip'} Adding a constant to a regression produces the same result as centering all variables and estimating without intercept. So, unless all variables are centered, **always** include an intercept in the regression. ```
To get a better feel for what is going on here, you can try this out now by yourself by typing: ```{r,eval=FALSE} launchApp("demeaned_reg") ``` ### Standardizing A Regression {#reg-standard} *Standardizing* a variable $z$ means to demean as above, but in addition to divide the demeaned value by its own standard deviation. Similarly to what we did above for *centering*, we define transformed variables $\breve{y}_i = \frac{y_i-\bar{y}}{\sigma_y}$ and $\breve{x}_i = \frac{x_i-\bar{x}}{\sigma_x}$ where $\sigma_z$ is the standard deviation of variable $z$. From here on, you should by now be used to what comes next! As above, we use $\breve{x}_i,\breve{y}_i$ instead of $x_i,y_i$ in \@ref(eq:b1line) to this time obtain: \begin{align} b_1 &= \frac{\frac{1}{N}\sum_{i=1}^N \breve{x}_i \breve{y}_i}{\frac{1}{N}\sum_{i=1}^N \breve{x}_i^2}\\ &= \frac{\frac{1}{N}\sum_{i=1}^N \frac{x_i - \bar{x}}{\sigma_x} \frac{y_i - \bar{y}}{\sigma_y}}{\frac{1}{N}\sum_{i=1}^N \left(\frac{x_i - \bar{x}}{\sigma_x}\right)^2} \\ &= \frac{Cov(x,y)}{\sigma_x \sigma_y} \\ &= Corr(x,y) (\#eq:bline-standardized) \end{align} ```{block type='tip'} After we standardize both $y$ and $x$, the slope coefficient $b_1$ in the regression without intercept is equal to the **correlation coefficient**. ```
And also for this case we have a practical application for you. Just type this and play around with the app for a little while! ```{r,eval=FALSE} launchApp("reg_standardized") ``` ## Predictions and Residuals {#pred-resids} Now we want to ask how our residuals $e_i$ relate to the prediction $\hat{y_i}$. Let us first think about the average of all predictions $\hat{y_i}$, i.e. the number $\frac{1}{N} \sum_{i=1}^N \hat{y_i}$. Let's just take \@ref(eq:abline-pred) and plug this into this average, so that we get \begin{align} \frac{1}{N} \sum_{i=1}^N \hat{y_i} &= \frac{1}{N} \sum_{i=1}^N b_0 + b_1 x_i \\ &= b_0 + b_1 \frac{1}{N} \sum_{i=1}^N x_i \\ &= b_0 + b_1 \bar{x} \\ \end{align} But that last line is just equal to the formula for the OLS intercept \@ref(eq:beta0hat), $b_0 = \bar{y} - b_1 \bar{x}$! That means of course that $$ \frac{1}{N} \sum_{i=1}^N \hat{y_i} = b_0 + b_1 \bar{x} = \bar{y} $$ in other words: ```{block type='tip'} The average of our predictions $\hat{y_i}$ is identically equal to the mean of the outcome $y$. This implies that the average of the residuals is equal to zero. ```
Related to this result, we can show that the prediction $\hat{y}$ and the residuals are *uncorrelated*, something that is often called **orthogonality** between $\hat{y}_i$ and $e_i$. We would write this as \begin{align} Cov(\hat{y},e) &=\frac{1}{N} \sum_{i=1}^N (\hat{y}_i-\bar{y})(e_i-\bar{e}) = \frac{1}{N} \sum_{i=1}^N (\hat{y}_i-\bar{y})e_i \\ &= \frac{1}{N} \sum_{i=1}^N \hat{y}_i e_i-\bar{y} \frac{1}{N} \sum_{i=1}^N e_i = 0 \end{align} It's useful to bring back the sample data which generate figure \@ref(fig:line-arrows) at this point in order to verify these claims: ```{r,echo=FALSE} ss = subset(plot_data,select=c(y,y_hat,error)) round(ss,2) ``` Let's check that these claims are true in this sample of data. We want that 1. The average of $\hat{y}_i$ to be the same as the mean of $y$ 2. The average of the errors should be zero. 3. Prediction and errors should be uncorrelated. ```{r} # 1. all.equal(mean(ss$error), 0) # 2. all.equal(mean(ss$y_hat), mean(ss$y)) # 3. all.equal(cov(ss$error,ss$y_hat), 0) ``` So indeed we can confirm this result with our test dataset. Great! ## Correlation, Covariance and Linearity It is important to keep in mind that Correlation and Covariance relate to a *linear* relationship between `x` and `y`. Given how the regression line is estimated by OLS (see just above), you can see that the regression line inherits this property from the Covariance. A famous exercise by Francis Anscombe (1973) illustrates this by constructing 4 different datasets which all have identical **linear** statistics: mean, variance, correlation and regression line *are identical*. However, the usefulness of the statistics to describe the relationship in the data is not clear. ```{r,echo=FALSE} ##-- now some "magic" to do the 4 regressions in a loop: ff <- y ~ x mods <- setNames(as.list(1:4), paste0("lm", 1:4)) for(i in 1:4) { ff[2:3] <- lapply(paste0(c("y","x"), i), as.name) ## or ff[[2]] <- as.name(paste0("y", i)) ## ff[[3]] <- as.name(paste0("x", i)) mods[[i]] <- lmi <- lm(ff, data = anscombe) } op <- par(mfrow = c(2, 2), mar = 0.1+c(4,4,1,1), oma = c(0, 0, 2, 0)) for(i in 1:4) { ff[2:3] <- lapply(paste0(c("y","x"), i), as.name) plot(ff, data = anscombe, col = "red", pch = 21, bg = "orange", cex = 1.2, xlim = c(3, 19), ylim = c(3, 13),main=paste("dataset",i)) abline(mods[[i]], col = "blue") } par(op) ``` The important lesson from this example is the following: ```{block,type="warning"} Always **visually inspect** your data, and don't rely exclusively on summary statistics like *mean, variance, correlation and regression line*. All of those assume a **linear** relationship between the variables in your data. ```
The mission of Anscombe has been continued recently. As a result of this we can have a look at the `datasauRus` package, which pursues Anscbombe's idea through a multitude of funny data sets, all with the same linear statistics. Don't just compute the covariance, or you might actually end up looking at a Dinosaur! What? Type this to find out: ```{r,eval=FALSE} launchApp("datasaurus") aboutApp("datasaurus") ``` ### Non-Linear Relationships in Data Suppose our data now looks like this: ```{r non-line-cars,echo=FALSE} with(mtcars,plot(hp,mpg,xlab="x",ylab="y")) ``` Putting our previous *best line* defined in equation \@ref(eq:abline) as $y = b_0 + b_1 x + e$, we get something like this: ```{r non-line-cars-ols,echo=FALSE,fig.align='center',fig.cap='Best line with non-linear data?'} l1 = lm(mpg~hp,data=mtcars) plot(mtcars$hp,mtcars$mpg,xlab="x",ylab="y") abline(reg=l1,lw=2) ``` Somehow when looking at \@ref(fig:non-line-cars-ols) one is not totally convinced that the straight line is a good summary of this relationship. For values $x\in[50,120]$ the line seems to low, then again too high, and it completely misses the right boundary. It's easy to address this shortcoming by including *higher order terms* of an explanatory variable. We would modify \@ref(eq:abline) to read now \begin{equation} y_i = b_0 + b_1 x_i + b_2 x_i^2 + e_i (\#eq:abline2) \end{equation} This is a special case of *multiple regression*, which we will talk about in chapter \@ref(multiple-reg). You can see that there are *multiple* slope coefficients. For now, let's just see how this performs: ```{r non-line-cars-ols2,echo=FALSE,fig.align="center",fig.cap="Better line with non-linear data!",echo=FALSE} l1 = lm(mpg~hp+I(hp^2),data=mtcars) newdata=data.frame(hp=seq(from=min(mtcars$hp),to=max(mtcars$hp),length.out=100)) newdata$y = predict(l1,newdata=newdata) plot(mtcars$hp,mtcars$mpg,xlab="x",ylab="y") lines(newdata$hp,newdata$y,lw=2) ``` ## Analysing $Var(y)$ Analysis of Variance (ANOVA) refers to a method to decompose variation in one variable as a function of several others. We can use this idea on our outcome $y$. Suppose we wanted to know the variance of $y$, keeping in mind that, by definition, $y_i = \hat{y}_i + e_i$. We would write \begin{align} Var(y) &= Var(\hat{y} + e)\\ &= Var(\hat{y}) + Var(e) + 2 Cov(\hat{y},e)\\ &= Var(\hat{y}) + Var(e) (\#eq:anova) \end{align} We have seen above in \@ref(pred-resids) that the covariance between prediction $\hat{y}$ and error $e$ is zero, that's why we have $Cov(\hat{y},e)=0$ in \@ref(eq:anova). What this tells us in words is that we can decompose the variance in the observed outcome $y$ into a part that relates to variance as *explained by the model* and a part that comes from unexplained variation. Finally, we know the definition of *variance*, and can thus write down the respective formulae for each part: * $Var(y) = \frac{1}{N}\sum_{i=1}^N (y_i - \bar{y})^2$ * $Var(\hat{y}) = \frac{1}{N}\sum_{i=1}^N (\hat{y_i} - \bar{y})^2$, because the mean of $\hat{y}$ is $\bar{y}$ as we know. Finally, * $Var(e) = \frac{1}{N}\sum_{i=1}^N e_i^2$, because the mean of $e$ is zero. We can thus formulate how the total variation in outcome $y$ is aportioned between model and unexplained variation: ```{block, type="tip"} The total variation in outcome $y$ (often called SST, or *total sum of squares*) is equal to the sum of explained squares (SSE) plus the sum of residuals (SSR). We have thus **SST = SSE + SSR**. ``` ## Assessing the *Goodness of Fit* In our setup, there exists a convenient measure for how good a particular statistical model fits the data. It is called $R^2$ (*R squared*), also called the *coefficient of determination*. We make use of the just introduced decomposition of variance, and write the formula as \begin{equation} R^2 = \frac{\text{variance explained}}{\text{total variance}} = \frac{SSE}{SST} = 1 - \frac{SSR}{SST}\in[0,1] (\#eq:Rsquared) \end{equation} It is easy to see that a *good fit* is one where the sum of *explained* squares (SSE) is large relativ to the total variation (SST). In such a case, we observe an $R^2$ close to one. In the opposite case, we will see an $R^2$ close to zero. Notice that a small $R^2$ does not imply that the model is useless, just that it explains a small fraction of the observed variation. ## An Example: A Log Wage Equation Let's consider the following example concerning wage data collected in the 1976 Current Population Survey in the USA.^[This example is close to the vignette of the [wooldridge](https://cloud.r-project.org/web/packages/wooldridge/index.html) package, whose author I hereby thank for the excellent work.] We want to investigate the relationship between average hourly earnings, and years of education. Let's start with a plot: ```{r wooldridge-wages, echo=TRUE,fig.cap='Wages vs Education from the wooldridge dataset wage1.',fig.height=7} data("wage1", package = "wooldridge") # load data # a function that returns a plot plotfun <- function(wage1,log=FALSE,rug = TRUE){ y = wage1$wage if (log){ y = log(wage1$wage) } plot(y = y, x = wage1$educ, col = "red", pch = 21, bg = "grey", cex=1.25, xaxt="n", frame = FALSE, # set default x-axis to none main = ifelse(log,"log(Wages) vs. Education, 1976","Wages vs. Education, 1976"), xlab = "years of education", ylab = ifelse(log,"Log Hourly wages","Hourly wages")) axis(side = 1, at = c(0,6,12,18)) # add custom ticks to x axis if (rug) rug(wage1$wage, side=2, col="red") # add `rug` to y axis } par(mfcol = c(2,1)) # set up a plot with 2 panels # plot 1: standard scatter plot plotfun(wage1) # plot 2: add a panel with histogram+density hist(wage1$wage,prob = TRUE, col = "grey", border = "red", main = "Histogram of wages and Density",xlab = "hourly wage") lines(density(wage1$wage), col = "black", lw = 2) ``` ```{r,echo=FALSE} par(mfcol = c(1,1)) ``` Looking at the top panel of figure \@ref(fig:wooldridge-wages), you notice two things: From the red ticks on the y axis, you see that wages are very concentrated at around 5 USD per hour, with fewer and fewer observations at higher rates; and second, that it seems that the hourly wage seems to increase with higher education levels. The bottom panel reinforces the first point, showing that the estimated pdf (probability density function) shown as a black line has a very long right tail: there are always fewer and fewer, but always larger and larger values of hourly wage in the data. ```{block,type="warning"} You have seen this shape of a distribution in the tutorial for chapter 2 already! Do you remember the name of this particular shape of a distribution? (why not type `ScPoEconometrics::runTutorial('chapter2')`) to check? ```
Let's run a first regression on this data to generate some intution: \begin{equation} \text{wage}_i = b_0 + b_1 \text{educ}_i + e_i (\#eq:wage) \end{equation} We use the `lm` function for this purpose as follows: ```{r} hourly_wage <- lm(formula = wage ~ educ, data = wage1) ``` and we can add the resulting regression line to our above plot: ```{r wooldridge-wages2, echo=TRUE,fig.cap='Wages vs Education from the wooldridge dataset wage1, with regression'} plotfun(wage1) abline(hourly_wage, col = 'black', lw = 2) # add regression line ``` The `hourly_wage` object contains the results of this estimation. We can get a summary of those results with the `summary` method: ```{r} summary(hourly_wage) ``` The main interpretation of this table can be read off the column labelled *Estimate*, reporting estimated coefficients $b_0,b_1$: 1. With zero year of education, the hourly wage is about -0.9 dollars per hour (row named `(Intercept)`) 1. Each additional year of education increase hourly wage by 54 cents. (row named `educ`) 1. For example, for 15 years of education, we predict roughly -0.9 + 0.541 * 15 = `r -0.9 + 0.541 * 15` dollars/h. ## Scaling Regressions ```{block type="tip"} Regression estimates ($b_0, b_1$) are in the scale *of the data*. The actual *value* of the estimates will vary, if we change the scale of the data. The overall fit of the model to the data would *not* change, however, so that the $R^2$ statistic would be constant. ```
Suppose we wanted to use the above estimates to report the effect of years of education on *annual* wages instead of *hourly* ones. Let's assume we have full-time workers, 7h per day, 5 days per week, 45 weeks per year. Calling this factor $\delta = 7 \times 5 \times 45 = 1575$, we have that $x$ dollars per hour imply $x \times \delta = x \times `r 7*5*45`$ dollars per year. What would be the effect of using $\tilde{y} = wage \times `r 7*5*45`$ instead of $y = wage$ as outcome variable on our regression coefficients $b_0$ and $b_1$? Well, let's try! ```{r,results= "asis",echo = FALSE} delta = 7*5*45 wage1$annual_wage <- wage1$wage * delta wage_annual <- lm(formula = annual_wage ~ educ, data = wage1) c1 = coef(hourly_wage) c2 = coef(wage_annual) stargazer::stargazer(hourly_wage, wage_annual, type = if (knitr:::is_latex_output()) "latex" else "html",title = "Effect of Scaling on Coefficients") ``` Let's call the coefficients in the column labelled (1) as $b_0$ and $b_1$, and let's call the ones in column (2) $b_0^*$ and $b_1^*$. In column (1) we see that another year increaeses hourly wage by `r round(c1[2],2)` dollars, as before. In column (2), the corresponding number is `r round(c2[2],2)`, i.e. another year of education will increase *annual* wages by `r round(c2[2],2)` dollars, on average. Notice however, that $b_0 \times \delta = `r round(c1[1],2)` \times `r delta` = `r round(c2[1],2)` = b_0^*$ and that $b_1 \times \delta = `r round(c1[2],2)` \times `r delta` = `r round(c2[2],2)` = b_1^*$, that is we just had to multiply both coefficients by the scaling factor applied to original outcome $y$ to obtain our new coefficients $b_0^*$ and $b_1^*$! Also, observe that the $R^2$s of both regressions are identical! So, really, we did not have to run the regression in column (2) at all to make this change: multiplying all coefficients through by $\delta$ is enough in this case. We keep the identically same fit to the data. Rescaling the regressors $x$ is slightly different, but it's easy to work out *how* different, given the linear nature of the covariance operator, which is part of the OLS estimator. Suppose we rescale $x$ by the number $c$. Then, using the OLS formula in \@ref(eq:beta1hat), we see that we get new slope coefficient $b_1^*$ via \begin{align} b_1^* &= \frac{Cov(cx,y)}{Var(cx)} \\ &= \frac{cCov(x,y)}{c^2 Var(x)} \\ &= \frac{1}{c} b_1. \end{align} As for the intercept, and by using \@ref(eq:beta0hat) \begin{align} b_0^* &= \bar{y} - b_1^* \frac{1}{N}\sum_{i=1}^N c \cdot x_i \\ &= \bar{y} - b_1^* \frac{c}{N}\sum_{i=1}^N x_i \\ &= \bar{y} - \frac{1}{c} b_1 c * \bar{x} \\ &= \bar{y} - b_1 * \bar{x} \\ &= b_0 \end{align} That is, we change the slope by the *inverse* of the scaling factor applied to regressor $x$, but the intercept is unaffected from this. You should play around for a while with our rescaling app to get a feeling for this: ```{r,eval=FALSE} library(ScPoApps) launchApp('Rescale') ``` ## A Particular Rescaling: The $\log$ Transform The natural logarithm is a particularly important transformation that we often encounter in economics. Why would we transform a variable with the $\log$ function to start with? 1. Several important economic variables (like wages, city size, firm size, etc) are approximately *log-normally* distributed. By transforming them with the $\log$, we obtain an approximately *normally* distributed variable, which has desirable properties for our regression. 1. Applying the $\log$ reduces the impact of outliers. 1. The transformation allows for a convenient interpretation in terms of *percentage changes* of the outcome variable. Let's investigate this issue in our running example by transforming the wage data above. Look back at the bottom panel of figure \@ref(fig:wooldridge-wages): Of course you saw immediately that this looked a lot like a log-normal distribution, so point 1. above applies. We modify the left hand side of equation \@ref(eq:wage): \begin{equation} \log(\text{wage}_i) = b_0 + b_1 \text{educ}_i + e_i (\#eq:log-wage) \end{equation} Let's use the `update` function to modify our previous regression model: ```{r} log_hourly_wage = update(hourly_wage, log(wage) ~ ., data = wage1) ``` The `update` function takes an existing `lm` object, like `hourly_wage` here, and updates the `formula`. Here the `.` on the right hand side means *leave unchanged* (so the RHS stays unchanged). How do our pictures change? ```{r logplot,echo = TRUE} par(mfrow = c(1,2)) plotfun(wage1,rug = FALSE) abline(hourly_wage, col = 'black', lw = 2) # add regression line plotfun(wage1,log = TRUE, rug = FALSE) abline(log_hourly_wage, col = 'black', lw = 2) # add regression line par(mfrow = c(1,1)) ``` It *looks as if* the regression line has the same slope, but beware of the different scales of the y-axis! You can clearly see that all y-values have been compressed by the log transformation. The log case behaves differently from our *scaling by a constant number* case above because it is a *nonlinear* function. Let's compare the output between both models: ```{r,echo = FALSE, results = "asis"} stargazer::stargazer(hourly_wage, log_hourly_wage, title = "Log Transformed Equation",type = if (knitr:::is_latex_output()) "latex" else "html") ``` The interpretation of the transformed model in column (2) is now the following: ```{block type = "note"} We call a regression of the form $\log(y) = b_0 + b_1 x + u$ a *log-level* specification, because we regressed the log of a variable on the level (i.e not the log!) of another variable. Here, the impact of increasing $x$ by one unit is to increase $y$ by $100 \times b_1$ **percent**. In our example: an additional year of education will increase hourly wages by 8.3%. Notice that this is very different from saying *...increases log hourly wages by 8.3%*, which is wrong. ```
Notice that the $R^2$ slightly improved, so have a better fit to the data. This is due the fact that the log compressed large outlier values. Whether we apply the $log$ to left or right-hand side variables makes a difference, as outlined in this important table:
We ask this kind of question all the time in econometrics. In figure \@ref(fig:plane3D-reg) you clearly see that both explanatory variables have a negative impact on the outcome of interest: as one increases either the horse power or the weight of a car, one finds that miles per gallon decreases. What is kind of hard to read off is *how negative* an impact each variable has in isolation. As a matter of fact, the kind of question asked here is so common that it has got its own name: we'd say "*ceteris paribus*, what is the impact of `hp` on `mpg`?". *ceteris paribus* is latin and means *the others equal*, i.e. all other variables fixed. In terms of our model in \@ref(eq:abline2d), we want to know the following quantity: \begin{equation} \frac{\partial mpg_i}{\partial hp_i} = b_1 (\#eq:abline2d-deriv) \end{equation} The $\partial$ sign denotes a *partial derivative* of the function describing `mpg` with respect to the variable `hp`. It measures *how the value of `mpg` changes, as we change the value of `hp` ever so slightly*. In our context, this means: *keeping all other variables fixed, what is the effect of `hp` on `mpg`?*. We call the value of coefficient $b_1$ therefore also the *partial effect* of `hp` on `mpg`. In terms of our dataset, we use `R` to run the following **multiple regression**:
```{r,echo=FALSE} summary(fit) ``` From this table you see that the coefficient on `wt` has value `r round(coef(fit)[2],5)`. You can interpret this as follows: ```{block,type="warning"} Holding all other variables fixed at their observed values - or *ceteris paribus* - a one unit increase in $wt$ implies a -3.87783 units change in $mpg$. In other words, increasing the weight of a car by 1000 pounds (lbs), will lead to 3.88 miles less travelled per gallon. Similarly, a car with one additional horse power means that we will travel 0.03177 fewer miles per gallon of gasoline, *all else (i.e. $wt$) equal*. ``` ## Multicolinearity {#multicol} One important requirement for multiple regression is that the data be **not linearly dependent**: Each variable should provide at least some new information for the outcome, and it cannot be replicated as a linear combination of other variables. Suppose that in the example above, we had a variable `wtplus` defined as `wt + 1`, and we included this new variable together with `wt` in our regression. In this case, `wtplus` provides no new information. It's enough to know $wt$, and add $1$ to it. In this sense, `wt_plus` is a redundant variable and should not be included in the model. Notice that this holds only for *linearly* dependent variables - *nonlinear* transformations (like for example $wt^2$) are exempt from this rule. Here is why: \begin{align} y &= b_0 + b_1 \text{wt} + b_2 \text{wtplus} + e \\ &= b_0 + b_1 \text{wt} + b_2 (\text{wt} + 1) + e \\ &= (b_0 + b_2) + \text{wt} (b_1 + b_2) + e \end{align} This shows that we cannot *identify* the regression coefficients in case of linearly dependent data. Variation in the variable `wt` identifies a different coefficient, say $\gamma = b_1 + b_2$, from what we actually wanted: separate estimates for $b_1,b_2$. ```{block, type="note"} We cannot have variables which are *linearly dependent*, or *perfectly colinear*. This is known as the **rank condition**. In particular, the condition dictates that we need at least $N \geq K+1$, i.e. more observations than coefficients. The greater the degree of linear dependence amongst our explanatory variables, the less information we can extract from them, and our estimates becomes *less precise*. ``` ## Log Wage Equation Let's go back to our previous example of the relationship between log wages and education. How does this relationship change if we also think that experience in the labor market has an impact, next to years of education? Here is a picture: ```{r plane3D-lwage,echo=FALSE,fig.align='center',fig.cap='Log wages vs education and experience in 3D.',warning=FALSE,message=FALSE} data("wage1", package = "wooldridge") # linear fit log_wage <- lm(lwage ~ educ + exper,data=wage1) to_plot_x <- range(wage1$educ) to_plot_y <- range(wage1$exper) df <- data.frame(educ = rep(to_plot_x, 2), exper = rep(to_plot_y, each = 2)) df["pred"] <- predict.lm(log_wage, df, se.fit = F) surf <- acast(df, educ ~ exper) color <- rep(0, length(df)) wage1 %>% plot_ly(colors = "grey") %>% add_markers(x = ~educ, y = ~exper, z = ~lwage,name = "data",opacity = .8, marker=list(color = 'red', size = 5, hoverinfo="skip", opacity = 0.8)) %>% add_surface(x = to_plot_x, y = to_plot_y, z = ~surf, inherit = F, name = "wages 3D", opacity = .75, cauto = F, surfacecolor = color) %>% hide_colorbar() ``` Let's add even more variables! For instance, what's the impact of experience in the labor market, and time spent with the current employer? Let's first look at how those variables co-vary with each other: ```{r corrplot, fig.cap = "correlation plot"} cmat = round(cor(subset(wage1,select = c(lwage,educ,exper,tenure))),2) # correlation matrix corrplot::corrplot(cmat,type = "upper",method = "ellipse") ``` The way to read the so-called *correlation plot* in figure \@ref(fig:corrplot) is straightforward: each row illustrates the correlation of a certain variable with the other variables. In this example both the shape of the ellipse in each cell as well as their color coding tell us how strongly two variables correlate. Let us put this into a regression model now: ```{r,results = 'asis'} educ_only <- lm(lwage ~ educ , data = wage1) educ_exper <- lm(lwage ~ educ + exper , data = wage1) log_wages <- lm(lwage ~ educ + exper + tenure, data = wage1) stargazer::stargazer(educ_only, educ_exper, log_wages,type = if (knitr:::is_latex_output()) "latex" else "html") ``` Column (1) refers to model \@ref(eq:log-wage) from the previous chapter, where we only had `educ` as a regressor: we obtain an $R^2$ of 0.186. Column (2) is the model that generated the plane in figure \@ref(fig:plane3D-lwage) above. (3) is the model with three regressors. You can see that by adding more regressors, the quality of our fit increases, as more of the variation in $y$ is now accounted for by our model. You can also see that the values of our estimated coefficients keeps changing as we move from left to right across the columns. Given the correlation structure shown in figure \@ref(fig:corrplot), it is only natural that this is happening: We see that `educ` and `exper` are negatively correlated, for example. So, if we *omit* `exper` from the model in column (1), `educ` will reflect part of this correlation with `exper` by a lower estimated value. By directly controlling for `exper` in column (2) we get an estimate of the effect of `educ` *net of* whatever effect `exper` has in isolation on the outcome variable. We will come back to this point later on. ## How To Make Predictions {#make-preds} So suppose we have a model like $$\text{lwage} = b_0 + b_{1}(\text{educ}) + b_{2}(\text{exper}) + b_{3}(\text{tenure}) + \epsilon$$ How could we use this to make a *prediction* of log wages, given some new data? Remember that the OLS procedure gives us *estimates* for the values $b_0,b_1, b_2,b_3$. With those in hand, it is straightforward to make a prediction about the *conditional mean* of the outcome - just plug in the desired numbers for `educ,exper` and `tenure`. Suppose you want to know what the mean of `lwage` is conditional on `educ = 10,exper=4` and `tenure = 2`. You'd do \begin{align} E[\text{lwage}|\text{educ}=10,\text{exper}=4,\text{tenure}=2] &= b_0 + b_1 10 + b_2 4 + b_3 2\\ &= `r round(coef(log_wages) %*% c(1,10,4,2),2)`. \end{align} I computed the last line directly with ```{r,eval=FALSE} x = c(1,10,4,2) # 1 for intercept pred = coef(log_wages) %*% x ``` but `R` has a more complete prediction interface, using the function `predict`. For starters, you can predict the model on all data points which were contained in the dataset we used for estimation, i.e. `wage1` in our case: ```{r} head(predict(log_wages)) # first 6 observations of wage1 as predicted by our model ``` Often you want to add that prediction *to* the original dataset: ```{r} wage_prediction = cbind(wage1, prediction = predict(log_wages)) head(wage_prediction[, c("lwage","educ","exper","tenure","prediction")]) ``` You'll remember that we called the distance in prediction and observed outcome our *residual* $e$. Well here this is just `lwage - prediction`. Indeed, $e$ is such an important quantity that `R` has a convenient method to compute $y - \hat{y}$ from an `lm` object directly - the method `resid`. Let's add another column to `wage_prediction`: ```{r} wage_prediction = cbind(wage_prediction, residual = resid(log_wages)) head(wage_prediction[, c("lwage","educ","exper","tenure","prediction","residual")]) ``` Using the data in `wage_prediction`, you should now check for yourself what we already know about $\hat{y}$ and $e$ from section \@ref(pred-resids): 1. What is the average of the vector `residual`? 1. What is the average of `prediction`? 1. How does this compare to the average of the outcome `lwage`? 1. What is the correlation between `prediction` and `residual`? ================================================ FILE: 05-Categorial-Vars.Rmd ================================================ # Categorial Variables {#categorical-vars} Up until now, we have encountered only examples with *continuous* variables $x$ and $y$, that is, $x,y \in \mathbb{R}$, so that a typical observation could have been $(y_i,x_i) = (1.5,5.62)$. There are many situations where it makes sense to think about the data in terms of *categories*, rather than continuous numbers. For example, whether an observation $i$ is *male* or *female*, whether a pixel on a screen is *black* or *white*, and whether a good was produced in *France*, *Germany*, *Italy*, *China* or *Spain* are all categorical classifications of data. Probably the simplest type of categorical variable is the *binary*, *boolean*, or just *dummy* variable. As the name suggests, it can take on only two values, `0` and `1`, or `TRUE` and `FALSE`. ## The Binary Regressor Case Even though this is an extremely parsimonious way of encoding that, it is a very powerful tool that allows us to represent that a certain observation $i$ **is a member** of a certain category $j$. For example, let's imagine we have income data on males and females, and we would create a variable called `is.male` that is `TRUE` whenever $i$ is male, `FALSE` otherwise, and similarly for women. For example, to encode whether subject $i$ is male, one could do this: \begin{align*} \text{is.male}_i &= \begin{cases} 1 & \text{if }i\text{ is male} \\ 0 & \text{if }i\text{ is not male}. \\ \end{cases}, \\ \end{align*} and similarly for females, we'd have \begin{align*} \text{is.female}_i &= \begin{cases} 1 & \text{if }i\text{ is female} \\ 0 & \text{if }i\text{ is not female}. \\ \end{cases} \\ \end{align*} By definition, we have just introduced a linear dependence into our dataset. It will always be true that $\text{is.male}_i + \text{is.female}_i = 1$. This is because dummy variables are based on data being mutually exclusively categorized - here, you are either male or female.^[There are [transgender](https://en.wikipedia.org/wiki/Transgender) individuals where this example will not apply.] This should immediately remind you of section \@ref(multicol) where we introduced *multicolinearity*. A regression of income on both of our variables like this $$ y_i = b_0 + b_1 \text{is.female}_i + b_2 \text{is.male}_i + e_i $$ would be invalid because of perfect colinearity between $\text{is.female}_i$ and $\text{is.male}_i$. The solution to this is pragmatic and simple: ```{block, type="tip"} In dummy variable regressions, we remove one category from the regression (for example here: `is.male`) and call it the *reference category*. The effect of being *male* is absorbed in the intercept. The coefficient on the remaining categories measures the *difference* in mean outcome with respect to the reference category. ```
Now let's try this out. We start by creating the female indicator as above, $$ \text{is.female}_i = \begin{cases} 1 & \text{if }i\text{ is female} \\ 0 & \text{if }i\text{ is not female}. \\ \end{cases} $$ and let's suppose that $y_i$ is a measure of $i$'s annual labor income. Our model is \begin{equation} y_i = b_0 + b_1 \text{is.female}_i + e_i (\#eq:dummy-reg) \end{equation} and here is how we estimate this in `R`: ```{r, echo=FALSE} set.seed(19) n = 50 b0 = 2 b1 = -3 x = sample(x = c(0, 1), size = n, replace = T) y = b0 + b1 * x + rnorm(n) dta = data.frame(x,y) zero_one = lm(y~x,dta) ``` ```{r, dummy-reg} # x = sample(x = c(0, 1), size = n, replace = T) dta$is.female = factor(x) # convert x to factor dummy_reg = lm(y~is.female,dta) summary(dummy_reg) ``` Notice that `R` displays the *level* of the factor to which coefficient $b_1$ belongs here, i.e. `is.female1` means this coefficient is on level `is.female = 1` - the reference level is `is.female = 0`, and it has no separate coefficient. Also interesting is that $b_1$ is equal to the difference in conditional means between male and female $$b_1 = E[y|\text{is.female}=1] - E[y|\text{is.female}=0]=`r round(mean(dta[dta$x == 1, "y"]) - mean(dta[dta$x == 0, "y"]),4)`.$$ ```{block,type="note"} A dummy variable measures the difference or the *offset* in the mean of the response variable, $E[y]$, **conditional** on $x$ belonging to some category - relative to a baseline category. In our artificial example, the coefficient $b_1$ informs us that women earn on average 3.756 units less than men. ```
It is instructive to reconsider this example graphically: ```{r x-zero-one,fig.align='center',fig.cap='regressing $y \\in \\mathbb{R}$ on $\\text{is.female}_i \\in \\{0,1\\}$. The blue line is $E[y]$, the red arrow is the size of $b_1$. Which is the same as the slope of the regression line in this case and the difference in conditional means!',echo=FALSE} a <- coef(zero_one)[1] b <- coef(zero_one)[2] # plot expr <- function(x) a + b*x errors <- (a + b*x) - y plot(x, y, type = "p", pch = 21, col = "blue", bg = "royalblue", asp=.25, xlim = c(-.1, 1.1), ylim = c(min(y)-.1, max(y)+.1), frame.plot = T, cex = 1.2) points(0, mean(dta[dta$x == 0, "y"]), col = 'orange', cex = 3, pch = 15) text(0.05, mean(dta[dta$x == 0, "y"]), "E[Y | is.female = 0]", pos = 4) points(1, mean(dta[dta$x == 1, "y"]), col = 'orange', cex = 3, pch = 15) text(1.05, mean(dta[dta$x == 1, "y"]), "E[Y | is.female = 1]", pos = 4) curve(expr = expr, from = min(x)-10, to = max(x)+10, add = TRUE, col = "black") segments(x0 = x, y0 = y, x1 = x, y1 = (y + errors), col = "green") arrows(x0 =-1, y0 = mean(dta[dta$x == 0, "y"]), x1 = -1, y1 = mean(dta[dta$x == 1, "y"]),col="red",lw=3,code=3,length=0.1) # dashes segments(x0=-1,y0 = mean(dta[dta$x == 0, "y"]),x1=0,y1 = mean(dta[dta$x == 0, "y"]),col="red",lty="dashed") segments(x0=-1,y0 = mean(dta[dta$x == 1, "y"]),x1=1,y1 = mean(dta[dta$x == 1, "y"]),col="red",lty="dashed") text(-1, mean(y)+1, paste("b1=",round(b,2)), pos = 4,col="red") abline(a=mean(dta$y),b=0,col="blue",lw=2) ``` In figure \@ref(fig:x-zero-one) we see that this regression simplifies to the straight line connecting the mean, or the *expected value* of $y$ when $\text{is.female}_i = 0$, i.e. $E[y|\text{is.female}_i=0]$, to the mean when $\text{is.female}_i=1$, i.e. $E[y|\text{is.female}_i=1]$. It is useful to remember that the *unconditional mean* of $y$, i.e. $E[y]$, is going to be the result of regressing $y$ only on an intercept, illustrated by the blue line. This line will always lie in between both conditional means. As indicated by the red arrow, the estimate of the coefficient on the dummy, $b_1$, is equal to the difference in conditional means for both groups. You should look at our app now to deepen your understanding of what's going on here: ```{r,eval=FALSE} library(ScPoApps) launchApp("reg_dummy") ``` ## Dummy and Continuous Variables What happens if there are more predictors than just the dummy variable in a regression? For example, what if instead we had \begin{equation} y_i = b_0 + b_1 \text{is.female}_i + b_2 \text{exper}_i + e_i (\#eq:dummy-reg2) \end{equation} where $\text{exper}_i$ would measure years of experience in the labor market? As above, the dummy variable acts as an intercept shifter. We have \begin{equation} y_i = \begin{cases} b_0 + b_1 + b_2 \times \text{exper}_i + e_i & \text{if is.female=1} \\ b_0 + \hphantom{b_1} +b_2 \times \text{exper}_i + e_i & \text{if is.female=0} \end{cases} \end{equation} so that the intercept is $b_0 + b_1$ for women but $b_0$ for men. We will see this in the real-world example below, but for now let's see the effect of switching the dummy *on* and *off* in this app: ```{r,eval=FALSE} library(ScPoApps) launchApp("reg_dummy_example") ``` ## Categorical Variables in `R`: `factor` `R` has extensive support for categorical variables built-in. The relevant data type representing a categorical variable is called `factor`. We encountered them as basic data types in section \@ref(data-types) already, but it is worth repeating this here. We have seen that a factor *categorizes* a usually small number of numeric values by *labels*, as in this example which is similar to what I used to create regressor `is.female` for the above regression: ```{r factors} is.female = factor(x = c(0,1,1,0), labels = c(FALSE,TRUE)) is.female ``` You can see the result is a vector object of type `factor` with 4 entries, whereby `0` is represented as `FALSE` and `1` as `TRUE`. An other example could be if we wanted to record a variable *sex* instead, and we could do ```{r} sex = factor(x = c(0,1,1,0), labels = c("male","female")) sex ``` You can see that this is almost identical, just the *labels* are different. ### More Levels We can go beyond *binary* categorical variables such as `TRUE` vs `FALSE`. For example, suppose that $x$ measures educational attainment, i.e. it is now something like $x_i \in \{\text{high school,some college,BA,MSc}\}$. In `R` parlance, *high school, some college, BA, MSc* are the **levels of factor $x$**. A straightforward extension of the above would dictate to create one dummy variable for each category (or level), like \begin{align*} \text{has.HS}_i &= \mathbf{1}[x_i==\text{high school}] \\ \text{has.someCol}_i &= \mathbf{1}[x_i==\text{some college}] \\ \text{has.BA}_i &= \mathbf{1}[x_i==\text{BA}] \\ \text{has.MSc}_i &= \mathbf{1}[x_i==\text{MSc}] \end{align*} but you can see that this is cumbersome. There is a better solution for us available: ```{r} factor(x = c(1,1,2,4,3,4),labels = c("HS","someCol","BA","MSc")) ``` Notice here that `R` will apply the labels in increasing order the way you supplied it (i.e. a numerical value `4` will correspond to "MSc", no matter the ordering in `x`.) ### Log Wages and Dummies {#factors} The above developed `factor` terminology fits neatly into `R`'s linear model fitting framework. Let us illustrate the simplest use by way of example. Going back to our wage example, let's say that a worker's wage depends on their education as well as their sex: \begin{equation} \ln w_i = b_0 + b_1 educ_i + b_2 female_i + e_i (\#eq:wage-sex) \end{equation} ```{r,results = "asis"} data("wage1", package = "wooldridge") wage1$female = as.factor(wage1$female) # convert 0-1 to factor lm_w = lm(lwage ~ educ, data = wage1) lm_w_sex = lm(lwage ~ educ + female, data = wage1) stargazer::stargazer(lm_w,lm_w_sex,type = if (knitr:::is_latex_output()) "latex" else "html") ``` We know the results from column (1) very well by now. How does the relationship change if we include the `female` indicator? Remember from above that `female` is a `factor` with two levels, *0* and *1*, where *1* means *that's a female*. We see in the above output that `R` included a regressor called `female1`. This is a combination of the variable name `female` and the level which was included in the regression. In other words, `R` chooses a *reference category* (by default the first of all levels by order of appearance), which is excluded - here this is `female==0`. The interpretation is that $b_2$ measures the effect of being female *relative* to being male. `R` automatically creates a dummy variable for each potential level, excluding the first category. ```{r wage-plot,fig.align='center',echo=FALSE,fig.cap='log wage vs educ. Right panel with female dummy.',message=FALSE,warning=FALSE,fig.height=3} library(ggplot2) p1 = ggplot(mapping = aes(y=lwage,x=educ), data=wage1) + geom_point(shape=1,alpha=0.6) + geom_smooth(method="lm",col="blue",se=FALSE) + theme_bw() p_sex = cbind(wage1,pred=predict(lm_w_sex)) # p_sex = dplyr::sample_n(p_sex,2500) p2 <- ggplot(data=p_sex,mapping=aes(x=educ,y=lwage,color=female)) p2 <- p2 + geom_jitter(shape=1,alpha=0.6,width=0.1) + geom_line(mapping = aes(y=pred), size=1) + theme_bw() + scale_y_continuous(name = NULL) cowplot::plot_grid(p1,p2, rel_widths = c(1,1.2)) ``` Figure \@ref(fig:wage-plot) illustrates this. The left panel is our previous model. The right panel adds the `female` dummy. You can see that both male and female have the same upward sloping regression line. But you can also see that there is a parallel downward shift from male to female line. The estimate of $b_2 = `r round(coef(lm_w_sex)[3],2)`$ is the size of the downward shift. ## Interactions Sometimes it is useful to let the slope of a certain variable to be dependent on the value of *another* regressor. For example consider a model for the sales prices of houses, where `area` is the livable surface of the property, and `age` is its age: \begin{equation} \log(price) = b_0 + b_1 \text{area} + b_2 \text{age} + b_3 (\text{area} \times \text{age}) + e (\#eq:price-interact) \end{equation} In that model, the partial effect of `area` on `log(price)`, keeping all other variables fixed, is \begin{equation} \frac{\partial \log(price)}{\partial \text{area}} = b_1 + b_3 (\text{age}) \end{equation} If we find that $b_3 > 0$ in a regression, we conclude that the size of a house values more in older houses. We call $b_3$ the **interaction effect** between area and age. Let's look at that regression model now. ```{r} data(hprice3, package = "wooldridge") summary(lm(lprice ~ area*age, data = hprice3)) ``` In this instance, we see that indeed there is a small positive interaction between `area` and `age` on the sales price: even though `age` in isolation decreases the sales value, bigger houses command a small premium if they are older. ### Interactions with Dummies: Differential Slopes It is straightforward to extend the interactions logic to allow not only for different *intercepts*, but also different *slopes* for each subgroup in a dataset. Let's go back to our dataset of wages from section \@ref(factors) above. Now that we know how to create and interaction between two variables, we can easily modify equation \@ref(eq:wage-sex) like this: \begin{equation} \ln w = b_0 + b_1 \text{female} + b_2 \text{educ} + b_3 (\text{female} \times \text{educ}) + e (\#eq:wage-sex2) \end{equation} The only peculiarity here is that `female` is a factor with levels `0` and `1`: i.e. the interaction term $b_3$ will be zero for all men. Similarly to above, we can test whether there are indeed different returns to education or men and women by looking at the estimated value $b_3$: ```{r,echo = TRUE} lm_w_interact <- lm(lwage ~ educ * female , data = wage1) # R expands to full interactions model summary(lm_w_interact) ``` We will in the next chapter learn that the estimate for $b_3$ on the interaction `educ:female1` is difficult for us to distinguish from zero in a statistical sense; Hence for now we conclude that there are *no* significantly different returns in education for men and women in this data. This is easy to verify visually in this plot, where we are unable to detect a difference in slopes in the right panel. ```{r wage-plot2,fig.align='center',echo=FALSE,fig.cap='log wage vs educ. Right panel allows slopes to be different - turns out they are not!',message=FALSE,warning=FALSE,fig.height=3} p_sex = cbind(wage1,pred=predict(lm_w_sex)) p_sex = cbind(p_sex,pred_inter=predict(lm_w_interact)) # p_sex = dplyr::sample_n(p_sex,2500) p2 <- ggplot(data=p_sex,mapping=aes(x=educ,y=lwage,color=female)) p2 <- p2 + geom_jitter(shape=1,alpha=0.6,width=0.1) + geom_line(mapping = aes(y=pred), size=1) + theme_bw() + scale_y_continuous(name = "log wage") + ggtitle("Impose Parallel Slopes") + theme(legend.position = "none") p3 <- ggplot(data=p_sex,mapping=aes(x=educ,y=lwage,color=female)) p3 <- p3 + geom_jitter(shape=1,alpha=0.6,width=0.1) + geom_line(mapping = aes(y=pred_inter), size=1) + theme_bw() + scale_y_continuous(name = NULL) + ggtitle("Allow Different Slopes") + theme(legend.position = "none") cowplot::plot_grid(p2,p3) ``` ## (Unobserved) Individual Heterogeneity Finally, dummary variables are sometimes very important to account for spurious relationships in that data. Consider the following (artificial example): 1. Suppose we collected data on hourly wage data together with a the number of hours worked for a set of individuals. 1. We plot want to investigate labour supply behaviour of those individuals, hence we run regression `hours_worked ~ wage`. 1. We expect to get a positive coefficient on `wage`: the higher the wage, the more hours worked. 1. You know that individuals are members of either group `g=0` or `g=1`. ```{r, echo = FALSE} two_clouds <- function(a1 = 5, a2 = -2, b1 = 2.5, b2 = 1.5, n1 = 50, n2 = 50){ set.seed(12) x1 = rnorm(n1,mean = 1,sd = 0.5) x2 = rnorm(n2,mean = 1.3,sd = 0.5) y1 = a1 + b1 * x1 + rnorm(n1,sd = 2) y2 = a2 + b2 * x2 + rnorm(n2,sd = 2) x = c(x1,x2) y = c(y1,y2) g = factor(c(rep(1,n1),rep(2,n1))) z = data.frame(x,y,g) m1 = lm(y~x,data = z) m2 = update(m1, . ~ . + g) p1 = ggplot(z, aes(x,y)) + geom_point() + geom_smooth(method = "lm",se =FALSE) + scale_x_continuous(name = "wage") + scale_y_continuous(name = "hours") + theme_bw() p2 = ggplot(z, aes(x,y,color = g)) + geom_point() + geom_smooth(method = "lm",se = FALSE) + scale_x_continuous(name = "wage") + scale_y_continuous(name = "hours") + theme_bw() + ggtitle("Controlling for Group") # par(mfcol = c(1,2)) # plot(z$x,z$y) # abline(m1) list(m1=m1,m2=m2,p1 = p1, p = cowplot::plot_grid(p1,p2,rel_widths = c(1,1.2))) } tc = two_clouds() tc$p1 ``` Here we observe a slightly negative relationship: higher wages are associated with fewer hours worked? Maybe. But what is this, there is a group identifier in this data! Let's use this and include `g` as a dummy in the regression - suppose `g` encodes male and female. ```{r,echo = FALSE,fig.align='center',fig.cap='Left and right panel exhibit the same data. The right panel controls for group composition.',} tc$p ``` This is an artificial example; yet it shows that you can be severly misled if you don't account for group-specific effects in your data. The problem is particularly accute if we *don't know group membership* - we can then resort to advanced methods that are beyond the scope of this course to *estimate* which group each individual belongs to. If we *do know* group membership, however, it is good practice to include a group dummy so as to control for group effects. ================================================ FILE: 06-StdErrors.Rmd ================================================ # Regression Inference {#std-errors} In this chapter we want to investigate uncertainty in regression estimates. We want to understand what the precise meaning of the `Std. Error` column in a typical regression table is telling us. In terms of a picture, we want to understand better the meaning of the shaded area as in this one here: ```{r confint,fig.align="center",message=FALSE,warning=FALSE,echo=FALSE,fig.cap="Confidence bands around a regression line."} library(ggplot2) data("wage1", package = "wooldridge") p <- ggplot(mapping = aes(x = educ, y = lwage), data = subset(wage1,educ > 5)) # base plot p <- p + geom_point() # add points p <- p + geom_smooth(method = "lm", size=1, color="red") # add regression line p <- p + scale_y_continuous(name = "log hourly wage") + scale_x_continuous(name = "years of education") p + theme_bw() + ggtitle("Log Wages vs Education") ``` In order to fully understand this, we need to go back and make sure we have a good grasp of *sampling*. Let's do this first. ## Sampling In class we were confronted with a jar of Tricolore Fusilli pasta as picture in figure \@ref(fig:pasta1).^[This part is largely based on [moderndive](https://moderndive.com/7-sampling.html), to which I am giving full credit hereby. Thanks for this great idea.] We asked ourselves a question which, secretly, many of you had asked themselves at one point in their lives, namely: ```{block type = "tip"} What is the proportion of **green** Fusilli in a pack of Tricolore Fusilli? ```
Well, it's time to find out. ```{r pasta1, fig.cap="A glass jar filled with Fusilli pasta in three different colors.",echo = FALSE,fig.width = 8, out.width = "90%"} knitr::include_graphics("images/pasta1.JPG") ``` Let's call the fusilly in this jar our *study population*, i.e. the set of units about which we want to learn something. There are several approaches to address the question of how big a proportion in the population the green Fusilli make up. One obvious solution is to enumerate all Fusilli according to their color, and compute their proportion in the entire population. It works perfectly well as a solution, but is a long and arduous process, see figures \@ref(fig:pasta2) and \@ref(fig:pasta3). ```{r pasta2, fig.cap="Manually separating Fusilli by their color is very costly in terms of effort and cost.",echo = FALSE,fig.width = 8, out.width = "90%"} knitr::include_graphics("images/pasta2.JPG") ``` Additionally, you may draw worried looks from the people around you, while you are doing it. Maybe this is not the right way to approach this task?^[Regardless of the worried onlookers, I did what I had to do and I carried on to count the green pile. I know exactly how many greens are in there now! I then computed the weight of 20 Fusilli (5g), and backed out the number of Fusilli in the other piles. I will declare those numbers as the *true numbers*. (Sceptics are free to recount.)] ```{r pasta3, fig.cap="Heaps of Fusilli pasta ready to be counted.",echo = FALSE, out.width = "90%"} knitr::include_graphics("images/pasta3.JPG") ``` ### Taking One Sample From the Population We started by randomly grabbing a handful of Fusilli from the jar and by letting drop exactly $N=20$ into a paper coffee cup, pictured in \@ref(fig:pasta5). We call $N$ the *sample size*. The count and corresponding proportions of each color in this first sample are shown in the following table: Color | Count | Proportion :------:|:------:|:--------: Red | 7 | 0.35 Green | 5 | 0.25 White | 8 | 0.4 So far, so good. We have our first *estimate of the population proportion of green Fusilli in the overall population*: 0.25. Notice that taking a sample of $N=20$ was *much* quicker and *much less painful* than performing the full count (i.e. the *census*) of Fusilli performed above. ```{r pasta5, fig.cap="Taking one sample of 20 Fusilli from the jar.",echo = FALSE, out.width = "90%"} knitr::include_graphics("images/pasta5.JPG") ``` Then, we put my sample back into the jar, and we reshuffled the Fusilli. Had we taken *another* sample, again of $N=20$, would we again have gotten 7 Red, 5 Green, and 8 White, just as in the first sample? Maybe, but maybe not. Suppose we had carried on for several times drawing samples of 20 and counting the colors: Would we also have observed 5 green Fusilli? Definitely not. We would have noted some degree of *variability* in the proportions computed from our samples. The *sample proportions* in this case are an example of a *sample statistic*. ```{block type = "note"} **Sampling Variation** refers to the fact that if we *randomly* take samples from a wider population, the *random* composition of each sample will imply that we obtain statistics that vary - they take on potentially different values in each sample. ``` Let's see how this story evolved as we started taking more samples at a time. ## Taking Eleven Samples From The Population We formed teams of two students in class who would each in turn take samples from the jar (the population) of size $N=20$, as before. Each team computed the proportion of green Fusilli they had in their sample, and we wrote this data down in a table on the board. Then, we drew a histogram which showed how many samples had fallen into which bins. ```{r pasta6, fig.cap="Taking eleven samples of 20 Fusilli each from the jar, and plotting the histogram of obtained sample proportions of Green Fusilli.",echo = FALSE, out.width = "90%"} knitr::include_graphics("images/pasta6.JPG") ``` We looked at the histogram in figure \@ref(fig:pasta6) and we noted several things: 1. The largest proportions where 0.3 green 1. The smallest proportion was 0.15 green. 1. Most samples found a proportion of 0.25 green fusilli. 1. We did think that this looked *suspiciouly* like a **normal distribution**. We collected the sample data into a data.frame: ```{r sample-data} pasta_samples <- data.frame(group = 1:11, replicate = 1:11, prop_green = c(0.3,0.25,0.25,0.3,0.15,0.3,0.25,0.25,0.2,0.25,0.2)) pasta_samples ``` This produces an associated histogram which looks very much like the one we draws onto the board: ```{r pasta-hist,echo = FALSE} hist(pasta_samples$prop_green,breaks = c(0.125,0.175,0.225,0.275,0.325),main = "Histogram of 11 Pasta Samples", xlab = "Proportion of Green Fusilli") ``` ### Recap Let's recaptiulate what we just did. We wanted to know what proportion of Fusilli in the glass jar in figure \@ref(fig:pasta1) are green. We acknowledged that an exclusive count, or a census, is a costly and cumbersome exercise, which in most circumstances we will try to avoid. In order to make some progress nonetheless, we took a *random sample* from the full population in the jar: we randomly selected 20 Fusilli, and looked at the proportion of green ones in there. We found a proportion of 0.25. After replacing the Fusilli from the first sample in the jar, we asked ourselves if, upon drawing a *new* sample of 20 Fusilli, we should expect to see the same outcome - and we concluded: maybe, but maybe not. In short, we discovered some random variation from sample to sample. We called this **sampling variation**. The purpose of this little activity was three-fold: 1. To understand that random samples differ and that there is sampling variation. 1. To understand that bigger samples will yield smaller sampling variation. 1. To illustrate that the sampling distribution of *any* statistic (i.e. not only the sample proportion as in our case) computed from a random sample converges to a normal distribution as the sample size increases. ```{block type = "note"} The value of this exercise consisted in making **you** perform the sampling activity yourself. We will now hand over to the brilliant **moderndive** package, which will further develop this chapter. ``` ## Handover to `Moderndive` ```{r handover,out.width="90%", fig.cap="The Moderndive package used red and white balls instead of fusilli pasta.",echo = FALSE} knitr::include_graphics("images/transition.png") ``` The sampling activity in `moderndive` was performed with red and white balls instead of green fusilli pasta. The rest is identical. We will now read sections [7.2](https://moderndive.com/7-sampling.html#sampling-simulation) and [7.3](https://moderndive.com/7-sampling.html#sampling-framework) in their book, as well as [chapter 8 on confidence intervals adn bootstrapping](https://moderndive.com/8-confidence-intervals.html), and [chapter 9 on hypothesis testing](https://moderndive.com/9-hypothesis-testing.html). ## Uncertainty in Regression Estimates In the previous chapters we have seen how the OLS method can produce estimates about intercept and slope coefficients from data. You have seen this method at work in `R` by using the `lm` function as well. It is now time to introduce the notion that given that $b_0$, $b_1$ and $b_2$ are *estimates* of some unkown *population parameters*, there is some degree of **uncertainty** about their values. An other way to say this is that we want some indication about the *precision* of those estimates. The underlying issue that the data we have at hand are usually *samples* from a larger population. ```{block,type="note"}
## What is *true*? What are Statistical Models? A **statistical model** is simply a set of assumptions about how some data have been generated. As such, it models the data-generating process (DGP), as we have it in mind. Once we define a DGP, we could simulate data from it and see how this compares to the data we observe in the real world. Or, we could change the parameters of the DGP so as to understand how the real world data *would* change, could we (or some policy) change the corresponding parameters in reality. Let us now consider one particular statistical model, which in fact we have seen so many times already. ## The Classical Regression Model (CRM) {#class-reg} Let's bring back our simple model \@ref(eq:abline) to explain this concept. \begin{equation} y_i = \beta_0 + \beta_1 x_i + \varepsilon_i (\#eq:abline-5) \end{equation} The smallest set of assumptions used to define the *classical regression model* as in \@ref(eq:abline-5) are the following: 1. The data are **not linearly dependent**: Each variable provides new information for the outcome, and it cannot be replicated as a linear combination of other variables. We have seen this in section \@ref(multicol). In the particular case of one regressor, as here, we require that $x$ exhibit some variation in the data, i.e. $Var(x)\neq 0$. 1. The mean of the residuals conditional on $x$ should be zero, $E[\varepsilon|x] = 0$. Notice that this also means that $Cov(\varepsilon,x) = 0$, i.e. that the errors and our explanatory variable(s) should be *uncorrelated*. It is said that $x$ should be **strictly exogenous** to the model. These assumptions are necessary to successfully (and correctly!) run an OLS regression. They are often supplemented with an additional set of assumptions, which help with certain aspects of the exposition, but are not strictly necessary: 3. The data are drawn from a **random sample** of size $n$: observation $(x_i,y_i)$ comes from the exact same distribution, and is independent of observation $(x_j,y_j)$, for all $i\neq j$. 4. The variance of the error term $\varepsilon$ is the same for each value of $x$: $Var(\varepsilon|x) = \sigma^2$. This property is called **homoskedasticity**. 5. The error is normally distributed, i.e. $\varepsilon \sim \mathcal{N}(0,\sigma^2)$ Invoking assumption 5. in particular defines what is commonly called the *normal* linear regression model. ### $b$ is not $\beta$! Let's talk about the small but important modifications we applied to model \@ref(eq:abline) to end up at \@ref(eq:abline-5) above: * $\beta_0$ and $\beta_1$ and intercept and slope parameters * $\varepsilon$ is the error term. First, we *assumed* that \@ref(eq:abline-5) is the correct represenation of the DGP. With that assumption in place, the values $\beta_0$ and $\beta_1$ are the *true parameter values* which generated the data. Notice that $\beta_0$ and $\beta_1$ are potentially different from $b_0$ and $b_1$ in \@ref(eq:abline) for a given sample of data - they could in practice be very close to each other, but $b_0$ and $b_1$ are *estimates* of $\beta_0$ and $\beta_1$. And, crucially, those estimates are generated from a sample of data. Now, the fact that our data $\{y_i,x_i\}_{i=1}^N$ are a sample from a larger population, means that there will be *sampling variation* in our estimates - exactly like in the case of the sample mean estimating the population average as mentioned above. One particular sample of data will generate one particular set of estimates $b_0$ and $b_1$, whereas another sample of data will generate estimates which will in general be different - by *how much* those estimates differ across samples is the question in this chapter. In general, the more observations we have the greater the precision of our estimates, hence, the closer the estimates from different samples will lie together. ### Violating the Assumptions of the CRM {#violating} It's interesting to consider in which circumstances we might violate those assumptions. Let's give an example for each of them: 1. No Perfect Collinearity. We have seen that a perfect collinearity makes it impossible to compute to OLS coefficients. Remember the example about adding `wtplus = wt + 1` to the `mtcars` dataset? Here it is: ```{r,warning = FALSE, message = FALSE} library(dplyr) mtcars %>% mutate(wtplus = wt + 1) %>% lm(mpg ~ wt + wtplus, data = .) ``` That the coefficient on `wtplus` is `NA` is the result of the direct linear dependence. (Notice that creating `wtplus2 = (wt + 1)^2`) would work, since that is not linear!) 1. Conditional Mean of errors is zero, $E[\varepsilon|x] = 0$. Going back to our running example in figure \@ref(fig:confint) about wages and education: Suppose that each individual $i$ in our data something like *innate ability*, something we might wish to measure with an IQ-test, however imperfecty. Let's call it $a_i$. It seems reasonable to think that high $a_i$ will go together with high wages. At the same time, people with high $a_i$ will find studying for exams and school work much less burdensome than others, hence they might select into obtaining more years of schooling. The problem? Well, there is no $a_i$ in our regression equation - most of time we don't have a good measure of it to start with. So it's an *unobserved variable*, and as such, it is part of the error term $\varepsilon$ in our model. We will attribute to `educ` part of the effect on wages that is actually *caused* by ability $a_i$! Sometimes we may be able to reason about whether our estimate on `educ` is too high or too low, but we will never know it's true value. We don't get the *ceteris paribus* effect (the true partial derivative of `educ` on `lwage`). Technically, the assumption $E[\varepsilon|x] = 0$ implies that $Cov(\varepsilon,x) = 0$, so that's the part that is violated. 1. Data from Random Sample. One common concern here is that the observations in the data could have been *selected* in a particular fashion, which would make it less representative of the underlying population. Suppose we had ended up with individuals only from the richest neighborhood of town; Our interpretation the impact of education on wages might not be valid for other areas. 1. Homoskedasticity. For correct inference (below!), we want to know whether the variance of $\varepsilon$ varies with our explanatory variable $x$, or not. Here is a typical example where it does: ```{r,echo = FALSE} data("engel",package = "quantreg") plot(foodexp ~ log(income) ,data = engel,main = "Food Expenditure vs Log(income)") ``` As income increases, not all people increase their food consumption in an equal way. So $Var(\varepsilon|x)$ will vary with the value of $x$, hence it won't be equal to the constant $\sigma^2$. 1. If the distribution of $\varepsilon$ is not normal, it is more cumbersome to derive theoretical results about inference. ## Standard Errors in Theory {#se-theory} The standard deviation of the OLS parameters is generally called *standard error*. As such, it is just the square root of the parameter's variance. Under assumptions 1. through 4. above we can define the formula for the variance of our slope coefficient in the context of our single regressor model \@ref(eq:abline-5) as follows: \begin{equation} Var(b_1|x_i) = \frac{\sigma^2}{\sum_i^N (x_i - \bar{x})^2} (\#eq:var-ols) \end{equation} In pratice, we don't know the theoretical variance of $\varepsilon$, i.e. $\sigma^2$, but we form an estimate about it from our sample of data. A widely used estimate uses the already encountered SSR (sum of squared residuals), and is denoted $s^2$: $$ s^2 = \frac{SSR}{n-p} = \frac{\sum_{i=1}^n (y_i - b_0 - b_1 x_i)^2}{n-p} = \frac{\sum_{i=1}^n e_i^2}{n-p} $$ where $n-p$ are the *degrees of freedom* available in this estimation. $p$ is the number of parameters we wish to estimate (here: 1). So, the variance formula would become \begin{equation} Var(b_1|x_i) = \frac{SSR}{(n-p)\sum_i^N (x_i - \bar{x})^2} (\#eq:var-ols2) \end{equation} We most of the time work directly with the *standard error* of a coefficient, hence we define \begin{equation} SE(b_1) = \sqrt{Var(b_1|x_i)} = \sqrt{\frac{SSR}{(n-p)\sum_i^N (x_i - \bar{x})^2}} (\#eq:SE-ols2) \end{equation} You can clearly see that, as $n$ increases, the denominator increases, and therefore variance and standard error of the estimate will decrease. ================================================ FILE: 07-Causality.Rmd ================================================ # Causality {#causality} In this chapter we take on a challenging part of our course. Remember that in the [first set of slides](https://rawcdn.githack.com/ScPoEcon/ScPoEconometrics-Slides/session2_1/chapter1/chapter1.html) we introduced Econometrics as the economist's toolkit to answer questions like *does $x$ **cause** $y$?* Let's illustrate the issues at stake with a question from epidemiologie and public health: ```{block type = "warning"} Does smoking **cause** lung cancer? ```
Just in case you were wondering: Yes it does! However, for a very long time the *causal impact* of smoking on lung cancer was hotly debated, and it's instructive for us to look at this history.^[This chapter is drawn from chapter 5 of *The Book of Why* by [Judea Pearl](http://bayes.cs.ucla.edu/jp_home.html).] Let's go back to the 1950's. We are at the start of a big increase in deaths from lung cancer. At the same time cigarette consumption was growing very fast. With the benefit of hindsight, we can now draw this graph: ```{r smoking-cancer,echo = FALSE,fig.align = "center",fig.cap="Two time series showing cigarette consumption per capita and incidence of lung cancer in the USA."} knitr::include_graphics("images/Smoking_lung_cancer.png",) ``` However, time series graphs are poor tools to make causal statements. Many *other things* had changed from 1900 to 1950, all of which could equally be responsible for the rise in cancer rates: 1. Tarring of roads 1. Inhalation of motor exhausts (leaded gasoline fumes) 1. General greater air pollution. We call those other factors **confounders** of the relationship between smoking and lung cancer. So, there were a series of sceptics around who at the time were contesting the existing evidence. That evidence consisted in general of the following: 1. **Case-Control studies**: British Epidemiologists Richard Doll and Austin Bradford Hill started to compare people already diagnosed with cancer to those without, recording their history, and observable characteristics (like age and health behaviours). In one study, out of 649 lung cancer patients interviewed, all but 2 had been smokers! In that study, a cancer patient was 1.5 million times more likely to be have been a smoker than a non-smoker. Still, critics said, there are several sources of bias: * Hospital patients could be a selected sample of the general (smoking) population. * Patients could suffer from *recall bias*, affecting their recollection of facts. * So, while comparing cancer patients to non-patients and controlling for several important *confounders* (like age, income and other observable characteristics), there was still scope for bias. * Moreoever, replicating those studies, as Doll and Hill attempted, would not have solved this issue. 1. Next they attempted what doctors call a **Dose-Response Effect** study. In 1951 they sent out 60,000 questionnaires to British physicians asking about *their* smoking habits. Then they followed them over time: * Only 5 years on, heavy smokers had a death rate from lung cancer that was 24 times higher than for nonsmokers. * People who had smoked and then stopped reduced their risk by a factor of 2. * Still, notorious sceptics like R.A. Fisher were unconvinced. The studies *still* failed to compare **otherwise identical** smokers to non-smokers. There were *still* important unobserved confounders out there which could invalidate the conclusion that we observed indeed a **causal** relationship. Let's put a some structure on this problem now, so we can make progress. ## Directed Acyclical Graphs (DAG) {#dags} A DAG is a tool to visualize a causal relationship. It is a graph where nodes are connected via arrows, where an arrow can run in one direction only (hence, *directed* graph). If an arrow starts at node $x$ and ends at node $y$, we say that $x$ causes $y$. Here is a simple example of such a DAG: ```{r dag1,echo = FALSE,warning = FALSE,message = FALSE,fig.width=4,fig.height = 4, fig.align = "center",fig.cap = "A simple DAG showing the causal impact of $x$ on $y$."} library(ggdag) theme_set(theme_dag()) d1 = dagify(y ~ x) %>% ggdag() d1 ``` Now consider this setting, where there is a third variable, $z$. It could be possible that also $z$ has a direct influence on $y$: ```{r dag2,echo = FALSE,warning = FALSE,message = FALSE,fig.width=4,fig.height = 4, fig.align = "center",fig.cap = "A simple DAG with with 2 causal paths: Both $x$ and $z$ have a direct impact on $y$."} dagify(y ~ x, y ~ z) %>% ggdag() ``` Now let's change this and create a path from $z$ to *both* $x$ and $y$ instead. We call $z$ a *confounder* in the relationship between $x$ and $y$: $z$ *confounds* the direct causal impact of $x$ on $y$, by affecting them both at the same time. What is more, there is no arrow from $x$ to $y$ at all, so the only *real* explanatory variable here is in fact $z$. Attributing any explanatory power to $x$ would be wrong in this setting. ```{r dag3,echo = FALSE,warning = FALSE,fig.width=4,fig.height = 4, fig.align = "center",fig.cap = "A simple DAG where $z$ is a confounder. There is no causal path from $x$ to $y$, and any correlation we observe between those variables is completely induced by $z$. We call this spurious correlation."} ggdag_confounder_triangle() ``` Here is a second example where $z$ is a confounder, but slightly different. ```{r dag41,echo=FALSE,fig.cap="$z$ is still a confounder here, but there is a causal link from $x$ to $y$ now. If we observed $z$, we can control for it."} d4 = dagify(y ~ x, x ~ z, y ~ z) %>% tidy_dagitty(layout = "tree") %>% ggdag() d4 ``` In \@ref(fig:dag41) there is an arrow from $x$ to $y$. In this setting, if we are able to *observe* $z$, we can adjust the correlation we observe between $x$ to $y$ for the variation induced by $z$. In practice, this is precisely what multiple regression will do: holding $z$ fixed at some value, what is the partial effect of $x$ on $y$. Notice that $z$ cedes to be a confounder in this situation, and interpreting our regression coefficient on $x$ as *causal* is correct. ## Smoking in a DAG Let's use this and cast our problem as a DAG now. What the scientists in the 1950s faced where two competing models of the relationship between smoking and lung cancer: ```{r dag-cig,fig.height = 4,echo = FALSE,fig.cap = "Two competing causal graphs for the relationship between smoking and lung cancer. In the right panel Lung Cancer is directly impacted by a genetic factor, which at the same time also influences smoking. This is a stark representation of Fisher's view. Another version would have an additional arrow from Smoking to Lung Cancer in the right panel."} # https://cran.r-project.org/web/packages/ggdag/vignettes/bias-structures.html p1 = dagify(cancer ~ smoking, labels = c("cancer" = "Lung Cancer", "smoking" = "Smoking" ), exposure = "smoking", outcome = "cancer") %>% ggdag(text = FALSE, use_labels = "label") + ggtitle("Doll & Hill") + theme(plot.title = element_text(hjust = 0.5)) p2 = confounder_triangle(x = "Smoking", y = "Lung Cancer", z = "Gene") %>% ggdag(text = FALSE, use_labels = "label") + ggtitle("R.A. Fisher") + theme(plot.title = element_text(hjust = 0.5)) p3 <- dagify(cancer ~ smoking, smoking ~ gene, cancer ~ gene, outcome = "cancer", labels = c("gene" = "Gene", "cancer" = "Lung Cancer", "smoking" = "Smoking")) %>% tidy_dagitty(layout = "tree") %>% ggdag(text = FALSE, use_labels = "label") + ggtitle("Gene Partial") cowplot::plot_grid(p1,p2,axis = "tb") ``` Basically, what critics like Fisher were claiming was that the existing studies did not compare like for like. In other words, our *ceteris paribus* assumption was not satisfied. They were worried that *smoking* was not the only relevant difference between a population of smokers and one of non-smokers. In particular, they worried that people **self-selected** into smoking, and that the choice to become a smoker may be influenced by other, unobserved, underlying forces - like genetic predisposition, for example. That could mean that smokers were also more likely to take risks, or more likely to be heavy drinkers, or engage in other behaviours that might be conducive to develop lung cancer. They did not formulate it in terms of genetics at the time, because they could not know until the 2000's, when the human genome was sufficiently mapped to establish this fact (and indeed there **is** a smoking gene! But that's beside the point), but they worried about this factor. The argument was settled in the eyes of most physicians, when Jerome Cornfield in 1959 wrote a rebuttal of Fisher's points. Cornfield's strategy was to allow Fisher to have his unobserved factor, but to show that there was an upper bound to *how important* it could be in determining the outcome. Here goes: 1. Suppose there is indeed a confounding factor "smoking gene", and that it completely determines the risk of cancer in smokers. 1. Suppose smokers are observed to have 9 times the risk of non-smokers to develop lung cancer. 1. The smoking gene needs to be at least 9 times more prevalent in smokers than in non-smokers to explain this difference in risk. But now consider what this implies. Let's suppose that around 11% of all non-smokers have the smoking gene. That means that $9\times 11 = 99\%$ of smokers need to have it! What's even more worrying, if only even 12% of non smokers have the gene, then the argument breaks down because it would require $9\times 12 = 108\%$ of smokers to have it, which is of course impossible. This argument was so important that it got a name: **Cornfield's inequality**. It left of Fisher's argument nothing but a pile of rubble. It's impossible to think that genetic variation alone could be so important in determining a complex choice of becoming a smoker or not. Looking back at the right panel of figure \@ref(fig:dag-cig), the link from smoking to lung cancer was much too strong to be explained by the genetic hypothesis alone. ## Randomized Control Trials (RCT) Primer {#rct} We now present a quick introduction to Randomized Control Trials (RCTs). The history of randomization is fascinating and goes back a long time, again involving R.A. Fisher from above.^[I refer the interested student to the introduction of the *potential outcomes model* of [Scott Cunningham's](https://twitter.com/causalinf) [mixtape](http://scunning.com/cunningham_mixtape.pdf), which heavily influences this section.] Suffice it to say that RCTs have become so important in Economics that the [Nobel Price in Economics 2019](https://www.nobelprize.org/prizes/economic-sciences/2019/summary/) has been awarded to three exponents of the RCT literature, [Duflo, Banerje and Kremer](https://www.economist.com/finance-and-economics/2019/10/17/a-nobel-economics-prize-goes-to-pioneers-in-understanding-poverty). RCTs are widely used in Medicine, where they originate from (in some sense). But, what *are* RCTs? ```{block type="note"} A randomized controlled trial is a type of scientific experiment that aims to reduce certain sources of bias when testing the effectiveness of some intervention (treatment or policy); this is accomplished by randomly allocating subjects to two or more groups, treating them differently, and then comparing them with respect to a measured response. ```
That sounds really intuitive. If we *randomly* allocate people to receive treatment, there can be no concern of unobserved confounders, as we have relieved the subjects of making the choice to get treated. Remember the cigarette smokers above: The concern was that an unobserved genetic predisposition correlated with both choosing to become a smoker but also with other potentially cancer-inducing behaviours like drinking or risk taking. Imagine for a moment that we could randomly select people at some young age to be selected for treatment (smoking for 30 years, say). The genetic predisposition will be equally prevalent in both treatment and control group. However, only the treatment group is allowed (and indeed forced) to smoke. Observing higher cancer rates in the treatment group would provide *causal evidence* for the effect of smoking on lung cancer. Thankfully, such an experiment is impossible to run on ethical grounds. We could never subject individuals to such severe and prolongued health risks for the sake of a research study. That's why the question took to long to be settled! Let's introduce a formal framework now to think more about RCTs. ## The Potential Outcomes Model {#rubin} The Potential Outcomes Model, often named after one of it's inventors the *Rubin Causal Model*, posits that there are two states of the world - the *potential outcomes*. A first state, where a certain intervention is administered to an individual, and a second state, where this is not the case. Formally, this idea is expressed with superscripts 0 and 1, like this: * $Y_i^1$: individual $i$ has been treated * $Y_i^0$: individual $i$ has **not** been treated Denoting with $D_i \in \{0,1\}$ the treatment indicator which is one if $i$ is indeed treated, the *observed outcome* $Y_i$ is then \begin{equation} Y_i = D_i Y_i^1 + (1-D_i)Y_i^0 (\#eq:rubin-model) \end{equation} This simple equation is able to formalize a rather deep question. We only ever observe one outcome of events for a given individual $i$, say $Y_i = Y_i^1$ in case treatment was given. The deep question is: *what would have happened to $i$, had they **not** received treatment*? You will realize that this a very natural question for us humans to put to ourselves, and to subsequently answer: * How long would the trip have taken, had I chosen another metro line? * What would have happened, had I chosen to study a different subject? * What would have happend, had [Neo](https://en.wikipedia.org/wiki/Neo_(The_Matrix)) taken the blue pill instead? Our ability to make those considerations distinguishes us from animals. It's one of the biggest challenges for machines when trying to be *intelligent*. What makes this question so hard to answer for machines and animals alike is the fact that one has to *imagine a parallel universe* where the actions taken were different, **without** having observed that precise situation before. Neo did *not* take the blue pill, and whatever happened after that originated from this decision - so how are we to tell what would have happened? It's easy for us and [still hard for machines](https://www.quantamagazine.org/to-build-truly-intelligent-machines-teach-them-cause-and-effect-20180515/). Potential outcome $Y_i^0$ above is what is known as the *counterfactual* outcome. What would have happened to subject $i$, had they **not** received treatment $D$? Following Rubin, let us define the **treatment effect** for individual $i$ as follows: \begin{equation} \delta_i = Y_i^1 - Y_i^0 (\#eq:TE) \end{equation} Notice our insistence about talking about a single individual $i$ throughout here. Keeping the potential outcome model \@ref(eq:rubin-model) in mind, i.e. the fact that we only observe *one* of both outcomes, we face the **fundamental identification problem of program evaluation**: ```{block type="warning"} Given we only observe *one* potential outcome, we cannot compute the treatment effect $\delta_i$ for any individual $i$. ```
That's pretty dire news. Let's see if we can do better with an average effect instead. Let's define three *average* effects of interest: 1. the Average Treatment Effect (ATE): $$\delta^{ATE} = E[\delta_i] = E[Y_i^1] - E[Y_i^0]$$ 1. the Average Treatment on the Treated (ATT): $$\delta^{ATT} = E[\delta_i|D_i = 1] = E[Y_i^1|D_i = 1] - E[Y_i^0|D_i = 1]$$ 1. the Average Treatment on the Untreated (ATU): $$\delta^{ATU} = E[\delta_i|D_i = 0] = E[Y_i^1|D_i = 0] - E[Y_i^0|D_i = 0]$$ Notice that *none* of those can be computed from data either, because all of them require data on individual $i$ from *both* scenarios. Let's focus on the ATE for now. Fundamentally we face a **missing data problem**: either $Y_i^1$ or $Y_i^0$ are missing from our dataset. Nevertheless, let's setup the following *naive* simple difference in means estimator $\hat{\delta}$: \begin{align} \hat{\delta} =& E[Y_i^1|D_i = 1] - E[Y_i^0|D_i = 0]\\ =& \frac{1}{N_T} \sum_{i \in T}^{N_T} T_i - \frac{1}{N_C} \sum_{j \in T}^{N_C} Y_j (\#eq:SDO) \end{align} in other words, we just difference the mean outcomes in both treatment (T) and control (C) groups. That is, $N_C$ is the number of people in the control group, $N_T$ is the same for treatment group. Now let's consider what randomly choosing people for treatment does. The key consideration here is that the true $\delta_i$ is potentially different for each person. That is, some people will have a high effect of treatment, while others may have a small (or even negative!) effect. To learn about the true $\delta^{ATE}$ from our naive $\hat{\delta}$, it matters who ends up being treated! Imagine that individuals have at least some partial knowledge about their likely *gains from treatment*, i.e. their personal $\delta_i$. If those who expect to benefit a lot will select disproportionately into treatment, then our estimator $\hat{\delta}$ will be biased upwards for the true average effect $\delta^{ATE}$. This is so because the average of observed outcomes in the treatment group, i.e. $$ \frac{1}{N_T} \sum_{i \in T}^{N_T} Y_i $$ will be **too high**. It represents the disproportionately *high* treatment outcome $Y_i^1$ for all those who *anticipated* such a high outcome from treatment, and who therefore were particularly eager to get selected into treatment. It's not *representative* of the true population wide treatment outcome $E[Y_i^1]$. Here is where randomization comes into play. Suppose we now flip a coin for each person to determine whether they obtain treatment or not. This takes away from them the possibility to select on expected gains into treatment. Crucially, the distribution of effects $\delta_i$ is still the same in the study population, i.e. there are still people with high and people with low effects. But we have solved the missing data problem mentioned above, because whether $Y_i^1$ or rather $Y_i^0$ is observed for each $i$ is now **random**, and no longer a function of any other factor that $i$ could act upon! Hooray! Notice how this links back to our initial discussion about DAGs above. Randomisation essentially cancels the links starting at confounder $z$ in \@ref(fig:dag41). ## Omitted Variable Bias and DAGs We want to revisit the underlying assumptions of the classical model outlined in \@ref(class-reg) in the previous chapter, which is closely related to the previous discussion. Let's talk a bit more about assumption number 2 of the definition in \@ref(class-reg). It said this: ```{block type='warning'} The mean of the residuals conditional on $x$ should be zero, $E[\varepsilon|x] = 0$. This means that $Cov(\varepsilon,x) = 0$, i.e. that the errors and our explanatory variable(s) should be *uncorrelated*. We want $x$ to be **strictly exogenous** to the model. ```
Let us start again with \begin{equation} y_i = \beta_0 + \beta_1 x_i + \varepsilon_i (\#eq:DGP-h) \end{equation} and imagine it represents the data generating process (DGP) of the impact of $x$ on $y$. Writing down this equation is tightly linked to drawing this DAG from above: ```{r dag4,fig.width=4,fig.height = 4, fig.align = "center",fig.cap = "The same simple DAG showing the causal impact of $x$ on $y$.",echo = FALSE} d1 ``` The role of $\varepsilon_i$ in equation \@ref(eq:DGP-h) is to allow for random variability in the data not captured by our model, almost as an acknowledgement that we would never be able to *fully* explain $y_i$ with our necessarily simple model. However, assumption $E[\varepsilon|x] = 0$ (or $Cov(\varepsilon,x) = 0$) makes sure that those other factors are in **no systematic relationship** with our regressor $x$. Why? Well if it *were* the case that another factor $z$ is related to $x$, we could never make our ceteris paribus statements of *holding all other factors fixed, the impact of $x$ on $y$ is $\beta$*. In other words, we'd have a confounder in our regression. ```{r dag5,echo = FALSE,fig.width=4,fig.height = 4, fig.align = "center",fig.cap = "The same simple DAG where $z$ is a confounder that needs to be controlled for."} d4 ``` Notice, again, that the key here is that if we don't control for $z$, it will form part of the error term $\varepsilon$. Given the causal link from $z$ to $x$, we will then observe that $Cov(x,u) = Cov(x,\varepsilon + z) \neq 0$, invalidating our assumption. ### House Prices and Bathrooms Let's imagine that equation \@ref(eq:DGP-h) represents the impact of number of bathrooms ($x$) on the sales price of houses ($y$). We run OLS as $$ y_i = b_0 + b_1 x_i + e_i $$ and find a positive impact of bathrooms on houses: ```{r housing,echo=TRUE} data(Housing, package="Ecdat") hlm = lm(price ~ bathrms, data = Housing) summary(hlm) ``` In fact, from this you conclude that each additional bathroom increases the sales price of a house by `r options(scipen=999);round(coef(hlm)[2],1)` dollars. Let's see if our assumption $E[\varepsilon|x] = 0$ is satisfied: ```{r,warning=FALSE,message=FALSE} library(dplyr) # add residuals to the data Housing$resid <- resid(hlm) Housing %>% group_by(bathrms) %>% summarise(mean_of_resid=mean(resid)) ``` Oh, that doesn't look good. Even though the unconditional mean $E[e] = 0$ is *very* close to zero (type `mean(resid(hlm))`!), this doesn't seem to hold at all by categories of $x$. This indicates that there is something in the error term $e$ which is *correlated* with `bathrms`. Going back to our discussion about *ceteris paribus* in section \@ref(ceteris), we stated that the interpretation of our OLS slope estimate is that ```{block,type="tip"} Keeping everything else fixed at the current value, what is the impact of $x$ on $y$? *Everything* also includes things in $\varepsilon$ (and, hence, $e$)! ```
It looks like our DGP in \@ref(eq:DGP-h) is the *wrong model*. Suppose instead, that in reality sales prices are generated like this: \begin{equation} y_i = \beta_0 + \beta_1 x_i + \beta_2 z_i + \varepsilon_i (\#eq:DGP-h2) \end{equation} This would now mean that by running our regression, informed by the wrong DGP, what we estimate is in fact this: $$ y_i = b_0 + b_1 x_i + (b_2 z_i + e_i) = b_0 + b_1 x_i + u_i. $$ This is to say that by *omitting* variable $z$, we relegate it to a new error term, here called $u_i = b_2 z_i + e_i$. Our assumption above states that *all regressors need to be uncorrelated with the error term* - so, if $Corr(x,z)\neq 0$, we have a problem. Let's take this idea to our running example. ### Including an Omitted Variable What we are discussing here is called *Omitted Variable Bias*. There is a variable which we omitted from our regression, i.e. we forgot to include it. It is often difficult to find out what that variable could be, and you can go a long way by just reasoning about the data-generating process. In other words, do you think it's *reasonable* that price be determined by the number of bathrooms only? Or could there be another variable, omitted from our model, that is important to explain prices, and at the same time correlated with `bathrms`? Let's try with `lotsize`, i.e. the size of the area on which the house stands. Intuitively, larger lots should command a higher price; At the same time, however, larger lots imply more space, hence, you can also have more bathrooms! Let's check this out: ```{r,echo=FALSE} options(scipen=0) hlm2 = update(hlm, . ~ . + lotsize) summary(hlm2) options(scipen=999) ``` Here we see that the estimate for the effect of an additional bathroom *decreased* from `r round(coef(hlm)[2],1)` to `r round(coef(hlm2)[2],1)` by almost 5000 dollars! Well that's the problem then. `r options(scipen=999)`We said above that one more bathroom is worth `r round(coef(hlm)[2],1)` dollars - if **nothing else changes**! But that doesn't seem to hold, because we have seen that as we increase `bathrms` from `1` to `2`, the mean of the resulting residuals changes quite a bit. So there **is something in $\varepsilon$ which does change**, hence, our conclusion that one more bathroom is worth `r round(coef(hlm)[2],1)` dollars is in fact *invalid*! The way in which `bathrms` and `lotsize` are correlated is important here, so let's investigate that: ```{r, fig.align='center', fig.cap='Distribution of `lotsize` by `bathrms`',echo=FALSE} options(scipen=0) h = subset(Housing,lotsize<13000 & bathrms<4) h$bathrms = factor(h$bathrms) ggplot(data=h,aes(x=lotsize,color=bathrms,fill=bathrms)) + geom_density(alpha=0.2,size=1) + theme_bw() ``` This shows that lotsize and the number of bathrooms is indeed positively related. Larger lot of the house, more bathrooms. This leads to a general result: ```{block type='note'} **Direction of Omitted Variable Bias** If the direction of correlation between omitted variable $z$ and $x$ is the same as that between $x$ and $y$, we will observe upward bias in our estimate of $b_1$, and vice versa if the correlations go in opposite directions. In other words, we have positive bias if $b_2 z_i > 0$ and vice versa. ```
================================================ FILE: 08-STAR.Rmd ================================================ # STAR Experiment {#STAR} How to best allocate spending on schooling is an important question. What's the impact of spending money to finance smaller classrooms on student performance and outcomes, both in the short and in the long run? A vast literature in economics is concerned with this question, and for a long time there was no consensus. The big underlying problem in answering this question is that we do not really know how student outcomes are *produced*. In other words, what makes a successful student? Is it the quality of their teacher? Surely matters. is it quality of the school building? Could be. Is it that the other pupils are of high quality and this somehow *rubs off* to weaker pupils? Also possible. What about parental background? Sure. You see that there are many potential channels that could determine student outcomes. What is more, there could be several interdependencies amongst those factors. Here's a DAG! ```{r star1,echo = FALSE,warning = FALSE,message = FALSE,fig.align = "center",fig.cap = "Possible Channels determining student outcomes. Dashed arrows represent potentially unobserved links."} library(ggdag) library(dplyr) p1 = dagify(outcome ~ teacher, size ~ building, outcome ~ building, outcome ~ peers, outcome ~ size, peers ~ size, outcome ~ parents, labels = c("teacher" = "teacher quality", "building" = "building quality", "size" = "class size", "peers" = "quality of peers", "parents" = "parental background", "outcome" = "student outcome" ), outcome = "outcome") %>% tidy_dagitty() %>% mutate(linetype = if_else(name %in% c("peers","parents","teacher"), "dashed","solid")) %>% ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_edges(aes(edge_linetype = linetype), show.legend = FALSE) + geom_dag_label_repel(aes(label=label)) + theme_dag() p1 ``` We will look at an important paper in this literature now, which used a randomized experiment to make some substantial progress in answering the question *what is the production function for student outcomes*. We will study @krueger1999, which analyses the Tennessee Student/Teacher Achievement Ratio Experiment, STAR in short. ## The STAR Experiment Starting in 1985-1986 and lasting for four years, young pupils starting Kindergarden *and their teachers* where randomly allocated to to several possible groups: 1. small classes with 13-17 students 2. regular classes with 22-25 students 3. regular classes with 22-25 students but with an additional full-time teaching aide. The experiment involved about 6000 students per year, for a total of 11,600 students from 80 schools. Each school was required to have at least on class of each size-type above, and random assignment happened *at the school level*. At the end of each school grade (kindergarden and grades 1 thru 3) the pupils were given a standardized test. Now, looking back at figure \@ref(fig:star1), what are the complications when we'd like to assess the impact of *class size* on student outcome? Put differently, why can't we just look at observational data of all schools (absent any experiment!), group classes by their size, and compute the mean outcomes for each group? Here is a short list: 1. There is selection into schools with different sized classes. Suppose parents have a prior that smaller classes are better - they will try to get their kids into those schools. 1. Relatedly, who ends up being in the classroom with a child could matter (peer effects). So, if high quality kids are sorting into schools with small classes, and if peer effects are strong, we could concluded that small classes improved student outcomes when in reality this was due to the high quality of peers in class. 1. Also related, teachers could sort towards schools with smaller classes because it's easier to teach a small rather than a large class, and if there is competition for those places, higher quality teachers will have an advantage. Now, what can STAR do for us here? There will still be selection into schools, however, once selected a school it is random whether one ends up in a small or a large class. So, the quality of peers present in the school (determined before the experiment through school choice) will be similar across small and big groups. In figure \@ref(fig:star1), you see that some factors are drawn as unobserved (dashed arrow), and some are observed (solid). In any observational dataset, the dashed arrows would be really troubling. Here, given randomisation into class sizes, *we don't care* whether those factors are unobserved or not: It's reasonable to assume that across randomly assigned groups, the distributions of each of those factors is roughly constant! If we *can* in fact proxy some of those factors (suppose we had data on teacher qualifications), even better, but not necessary to identify the causal effect of class size. ## PO as Regression Before we start replicating the findings in @krueger1999, let's augment our potential outcomes (PO) notation from the previous chapter. To remind you, we had defined the PO model in equation \@ref(eq:rubin-model): \begin{equation*} Y_i = D_i Y_i^1 + (1-D_i)Y_i^0 \end{equation*} and we had defined the treatment effect of individual $i$ as in \@ref(eq:TE): \begin{equation*} \delta_i = Y_i^1 - Y_i^0. \end{equation*} Now, as a start, let's assume that the treatment effect of *small class* is identical for all $i$: in that case we have \begin{equation*} \delta_i = \delta ,\forall i \end{equation*} Next, let's distribute the $Y_i^0$ in \@ref(eq:rubin-model) as follows: \begin{align*} Y_i &= Y_i^0 + D_i (Y_i^1 - Y_i^0 )\\ &= Y_i^0 + D_i \delta \end{align*} finally, let's add $E[Y_i^0] - E[Y_i^0]=0$ to the RHS of that last equation to get \begin{equation*} Y_i = E[Y_i^0] + D_i \delta + Y_i^0 - E[Y_i^0] \end{equation*} which we can rewrite in our well-known regression format \begin{equation} Y_i = b_0 + \delta D_i + u_i (\#eq:PO-reg) \end{equation} In that formulation, the first $E[Y_i^0]$ is the average non-treatment outcome, which we could regard as some sort of baseline - i.e. our intercept. $\delta$ is the coefficient on the binary treatment indicator. The random deviation $Y_i^0 - E[Y_i^0]$ is the residual $u$. Under only very specific circumstances will the OLS estimator $\hat{\delta}$ identify the true Average Treatment Effect $\delta^{ATE}$. Random assignment ensures that the crucial assumption $E[u|D] = E[Y_i^0 - E[Y_i^0]|D] = E[Y_i^0|D] - E[Y_i^0] = 0$, in other words, there is no difference in nontreatment outcomes across treatment groups. Additionally, we could easily include regressors $X_i$ in equation \@ref(eq:PO-reg) to account for additional variation in the outcome. With that out of the way, let's write down the regression that @krueger1999 wants to estimate. Equation (2) in his paper reads like this: \begin{equation} Y_{ics} = \beta_0 + \beta_1 \text{small}_{cs} + \beta_2 \text{REG/A}_{cs} + \beta_3 X_{ics} + \alpha_s + \varepsilon_{ics} (\#eq:krueger2) \end{equation} where $i$ indexes pupil, $c$ is class id and $s$ is the school id. $\text{small}_{cs}$ and $\text{REG/A}_{cs}$ are both dummy variables equal to one if class $c$ in school $s$ is either *small*, or *regular with aide*. $X_{ics}$ contains student specific controls (like gender). Importantly, given that randomization was at the school level, we control for the identify of the school with a school fixed effect $\alpha_s$. Before we proceed to run this regression, we need to define the outcome variable $Y_{ics}$. @krueger1999 combines the various SAT test scores in an average score for each student in each grade. However, given that the SAT scores are on different scales, he first computes a ranking of all scores for each subject (reading or math), and then assigns to each student their percentile in the rank distribution. The highest score is 100, the lowest score is 0. ## Implementing STAR Let's start with computing the ranking of grades. Let's load the data and the `data.table` package: ```{r,message = FALSE} data("STAR", package = "AER") library(data.table) x = as.data.table(STAR) x ``` It's a bit unfortunate to switch to data.table, but I haven't been able to do what I wanted in dplyr :-( . Ok, here goes. First thing, you can see that this data set is *wide*. First thing we want to do is to make it *long*, i.e. reshape it so that if has 4 ID columns, and several measurements columns thereafter. First, let's add a studend ID: ```{r} x[ , ID := 1:nrow(x)] # add a column called `ID` ``` ```{r} # `melt` a data.table means to dissolve it and reassamble for some ID variables mx = melt.data.table(x, id = c("ID","gender","ethnicity","birth"), measure.vars = patterns("star*","read*","math*", "schoolid*", "degree*","experience*","tethnicity*","lunch*"), value.name = c("classtype","read","math","schoolid","degree", "experience","tethniticy","lunch"), variable.name = "grade") levels(mx$grade) <- c("stark","star1","star2","star3") # reassign levels to grade factor mx[,1:8] # show first 8 cols ``` You can see here that for example pupil `ID=1` was not present in kindergarden, but joined later. We will only keep complete records, hence we drop those NAs: ```{r} mx <- mx[complete.cases(mx)] mx[ID==2] # here is pupil number 2 ``` Ok, now on to standardizing those `read` and `math` scores. you can see they are on their kind of arbitrary SAT scales ```{r} mx[,range(read)] ``` First thing to do is to create an empirical cdf of each of those scores within a certain grade. That is the *ranking* of scores from 0 to 1: ```{r,message = FALSE, results='hide'} setkey(mx, classtype) # key mx by class type ecdfs = mx[classtype != "small", # subset data.table to this list(readcdf = list(ecdf(read)), # create cols readcdf and mathcdf mathcdf = list(ecdf(math)) ), by = grade] # by grade # let's look at those cdf! om = par("mar") par(mfcol=c(4,2),mar = c(2,om[2],2.5,om[4])) ecdfs[,.SD[,plot(mathcdf[[1]],main = paste("math ecdf grade",.BY))],by = grade] ecdfs[,.SD[,plot(readcdf[[1]],main = paste("read ecdf grade",.BY))],by = grade] par(mfcol=c(1,1),mar = om) ``` You can see here how the cdf maps SAT scores (650, for example), into the interval $[0,1]$. Now, in the `ecdfs` `data.table` object, the `readcdf` column contains a *function* (a cdf) for each grade. We can evaluate the observed test scores for each student in that function to get their ranking in $[0,1]$, by grade: ```{r gradedens, fig.cap = "Reproducing Figure I in @krueger1999",fig.align="center"} setkey(ecdfs, grade) # key ecdfs according to `grade` setkey(mx,grade) z = mx[ , list(ID,perc_read = ecdfs[(.BY),readcdf][[1]](read), perc_math = ecdfs[(.BY),mathcdf][[1]](math)), by=grade] # stick `grade` into `ecdfs` as `.BY` z[,score := rowMeans(.SD)*100, .SDcols = c("perc_read","perc_math")] # take average of scores # and multiply by 100, so it's comparable to Krueger # merge back into main data mxz = merge(mx,z,by = c("grade","ID")) # make a plot ggplot(data = mxz, mapping = aes(x = score,color=classtype)) + geom_density() + facet_wrap(~grade) + theme_bw() ``` You can compare figure \@ref(fig:gradedens) to @krueger1999 figure 1. You can see that the density estimates are almost identical, the discrepancy comes mainly from the fact that we split the regular classes also by with/without aide. ```{r kruegerdens,echo=FALSE, fig.cap = "Outcome densities, @krueger1999 figure 1."} knitr::include_graphics("images/krueger1.png") ``` So far, so good! Now we can move to run a regression and estimate \@ref(eq:krueger2). ```{r} # create Krueger's dummy variables mxz = as_tibble(mxz) %>% mutate(small = classtype == "small", rega = classtype == "regular+aide", girl = gender == "female", freelunch = lunch == "free") # reproduce columns 1-3 m1 = mxz %>% group_by(grade) %>% do(model = lm(score ~ small + rega, data = .)) m2 = mxz %>% group_by(grade) %>% do(model = lm(score ~ small + rega + schoolid, data = .)) m3 = mxz %>% group_by(grade) %>% do(model = lm(score ~ small + rega + schoolid + girl + freelunch, data = .)) # get school id names to omit from regression tables school_co = grep(names(coef(m2[1,]$model[[1]])),pattern = "schoolid*",value=T) school_co = c(unique(school_co,grep(names(coef(m3[1,]$model[[1]])),pattern = "schoolid*",value=T)),"schoolid77") ``` Now let's look at each grade's models. ```{r} h = list() for (g in unique(mxz$grade)) { h[[g]] <- huxtable::huxreg(subset(m1,grade == g)$model[[1]], subset(m2,grade == g)$model[[1]], subset(m3,grade == g)$model[[1]], omit_coefs = school_co, statistics = c(N = "nobs", R2 = "r.squared"), number_format = 2 ) %>% huxtable::insert_row(c("School FE","No","Yes","Yes"),after = 11) %>% huxtable::theme_article() %>% huxtable::set_caption(paste("Estimates for grade",g)) %>% huxtable::set_top_border(12, 1:4, 2) } h$stark h$star1 h$star2 h$star3 ``` You should compare those to table 5 in @krueger1999, where it says *OLS: actual class size*. For the most part, we come quite close to his esimates! We did not follow his more sophisticated error structure (by allowing errors to be correlated at the classroom level), and we seem to have different number of individuals in each year. Here is his table 5: ```{r krug-table,echo=FALSE,fig.show = "hold", fig.align = "default"} knitr::include_graphics("images/krueger2.png",dpi = 300) knitr::include_graphics("images/krueger3.png",dpi = 300) knitr::include_graphics("images/krueger4.png",dpi = 300) knitr::include_graphics("images/krueger5.png",dpi = 300) ``` So, based on those results we can say that attending a small class raises student's test scores by about 5 percentage points. Unfortunately, says @krueger1999, is it hard to gauge whether those are big or small effects: how important is it to score 5% more or less? Well, you might say, it depends how close you are to an important cutoff value (maybe entrance to the next school level requires a score of `x`, and the 5% boost would have made that school feasible). Be that as it may, now you know more about one of the most influential papers in education economics, and why using an experimental setup allowed it to achieve credible causal estimates. ================================================ FILE: 09-RDD.Rmd ================================================ # Regression Discontinuity Design {#RDD} In the previous chapter we have seen how an experimental setup can be useful to recover causal effects from an OLS regression. In this chapter we will look at a similar approach where we don't randomly allocate subjects to either treatment or control (maybe because that's impossible to do in that particular situation), but where we can *zoom in* on a group of individuals where having been allocated to treatment is **as good as random** - hence not influenced by selection bias. The idea is called Regression Discontinuity Design, short RDD. ## RDD Setup Let's again start with a DAG for the main idea. Remember the numerical example in the set of slides on randomization, where we showed that if we know the allocating mechanism, we can recover the true ATE. RDD plays along those lines, in that we *know* how individuals got assigned to treatment. As is the case in many real-life situations, people are eligible for some treatment if some value **crosses a threshold**: * You are eligible to obtain a driving license as your age crosses the 18-year threshold. * You will receive pension benefits as your age crosses the 65-year threshold. * You are liable to criminal charges if you are caught with more than 3g of Marihuana in your pocket. * You are considered a subprime mortgage borrower if your loan-to-value ratio is above 95%. In RDD parlance, we call that particular variable we are looking at the *running variable* (age, quantity of Marihuana, LTV ratio etc). If we know the applicable threshold (18 years of age, say), and we know an individual's age, then it's trivial to figure out whether they were eligible to get a driving license. Let's formalize this a bit. Let's call the running variable $x$, the outcome $y$ as usual, let $D$ be the treament indicator and let us define a *threshold* value $c$. Treatment for individual $i$ will be such that \begin{equation*} D_i = \begin{cases}\begin{array}{c}1\text{ if }x_i > c \\ 0\text{ if }x_i \leq c. \end{array} \end{cases} \end{equation*} Here's the obligatory DAG! ```{r rdd1,echo = FALSE,warning = FALSE,message = FALSE,fig.align = "center",fig.cap = "DAG for a simple RDD design: $x$ determines treatment via the cutoff $c$"} library(ggdag) dagify(y ~ x, c ~ x, D ~ c, y ~ D) %>% ggdag(layout = "circle") + theme_dag() ``` The key idea can be glanced from figure \@ref(fig:rdd1): if we can *know* who ends up in treatment $D$, this can be useful for us to recover the true ATE. In particular, the idea is going to be to compare individuals who are *close* to the threshold $c$: Those with an $x$ *just above* the threshold should be comparable (in terms of their $x$!) to the ones *just below* $c$. Someone who has their 18th birthday next week is almost identical to someone how had their 18th birthday last week - in terms of age! So, computing our naive difference in mean outcomes for those narrowly defined groups should be a good approximation to a random allocation. Notice that there are two important things to keep in mind: 1. None of the other variables in the model should exhibit any discontinuity at $c$, other than $D$! 2. We obtain only *locally* valid identification of the ATE: as we move further and further away from the threshold, our individuals will cease to be really comparable. In our DAG, point 1 above is not currently visible. Let's augment this: ```{r rdd2,echo = FALSE,warning = FALSE,message = FALSE,fig.align = "center",fig.cap = "Augmented DAG for a simple RDD design: $x$ determines treatment via the cutoff $c$"} library(ggdag) dagify(y ~ x, c ~ x, D ~ c, y ~ z, y ~ D) %>% ggdag(layout = "circle") + theme_dag() ``` So, the condition we want is that additional explanatory variable $z$ does **not** suddenly jump as $x$ crosses $c$. Because we will be comparing the mean outcomes of people slightly to the left and right of $c$, we need to make sure that there is nothing that would *confound* our estimate of the size of the effect $\delta$. Let's look at an example of a recent RDD study now. ## Clicking on Heaven's Door In a recent paper title [Clicking on Heaven's Door](https://www.aeaweb.org/articles?id=10.1257/aer.20150355), U Bocconi economist [Paolo Pinotti](https://sites.google.com/view/paolo-pinotti/home) uses an RDD to show the effects of legal status of immigrants on criminal behaviour. The question of whether immigrants commit more or less crime than others (natives, for example) is a first order policy question. The question of that paper is what causal impact the *legal status* we confer upon an immigrant has on their propensity to commit a crime one year later. The study is based in Italy, where the legal status refers to an official permission to work. The key detail is that the residence permit needs to be sponsored by the immigrant's employer. ### Institutional Details In the Italian context, immigrants often enter illegally first, and then hope to obtain a residence permit through an employer later on. There is a quota system in place, which establishes how many permits are to be granted to how many people from each nationality, and to which Italian industries (construction, services, etc). See table \@ref(fig:pin1) for an overview of those quotas. ```{r pin1,echo=FALSE,fig.cap="Table 1 from @pinotti.",fig.align="center"} knitr::include_graphics("images/pinotti1.png") ``` Almost all of the estimated 650,000 illegal immigrants participate in the click days. @pinotti is able to link each immigrant to official interior ministry crime records, and is thus able to precisely identify whether an immigrant with a certain legal status is showing up in crime records in the year(s) after click days. ### Discontinuity Feature The principal feature of the Italian setting which makes this almost perfect for an RDD is the following: The quotas illustrated in \@ref(fig:pin1) are defined for a total of 1751 employer groups (varying by industry and location). Applications for a permit must be submitted online by employers, **starting at 8:00 AM on specific click days**, and will be given out on a first come first served basis. This implies that thousands of applicants are denied their permit each year not because they were not eligible (they had an employer sponsoring them!), but because they got late online (some seconds) when all permits for their specific quota were gone already. Here we formalize as $c$ the *exact* time the quota for a certain group was full, and the running variable $x$ is the *exact* time that the sponsoring employer clicked on the *submit* button on the website. This is measured at the level of milliseconds. The key observation is now that the exact timing when a certain quota is full, $c$, is impossible to foresee. Even if it is the case the employers of highly-skilled individuals are the first ones to log on, there is sufficient random variation (slow internet connection today...) in arrival times of employers on the platform such that we distribution of immigrant and employer types both sides of the cutoff $c$ are almost identical. So, it's very hard to *manipulate* the assignment rule. @pinotti experiments with several definitions of *close by the cutoff*, from 1 minute up to 30 minutes. The results are stable regardless of the definition chosen. ### Findings * In the year before click days, the crime rate for the individuals in the study is 1.1% in both treatment and control groups. * In the year after click days, crime rates decline to 0.8% for people who clicked before time $c$, and it stayed at 1.1% for people who came late. * The effect is mainly driven by so-called type A permits, which are given out to domestic employers (nannies, cleaning aides etc), while type B is for formal firms. Type A permits are easy to manipulate. Being granted legal status has a particularly large impact on reducing crime for type A permits. * There is no effect for type B permits. * Firm-sponsored applicants (type B) have a higher opportunity cost of crime already before click days - in the end they already are (informally) employed somewhere! Undocumented immigrants in domestic (fictitious) employment have a lower opportunity cost of crime. * At the same time, and crucially, that latter group seems to be particularly responsive to legalization, most likely because because a residence permit allows to search for work in the official labor market. * For people at the margin between persuing illegal activities or not, this is an important effect. * Figure \@ref(fig:pin2) illustrates this finding graphically with a typical RD plot. The vertical difference in red and green lines at the cutoff $T=0$ in the *2008: type-A applicants* is the estimate of the local average treatment effect (LATE), i.e. $0.5 - 1.8 = -1.3$. ```{r pin2,echo=FALSE,fig.cap="Table 3 from @pinotti.",fig.align="center"} knitr::include_graphics("images/pinotti2.png") ``` ================================================ FILE: 10-IV.Rmd ================================================ # Instrumental Variables (IV) {#IV} ```{r, echo = FALSE} library(modelsummary) gm = modelsummary::gof_map gm$omit <- TRUE gm$omit[gm$clean == "R2"] <- FALSE gm$omit[gm$clean == "Num.Obs."] <- FALSE gom = "p.value.|se_type|statistic.end|statistic.overid|statistic.weakinst" ``` In the previous chapters we have seen how to get credible causal estimates for the effect of some intervention via randomization techniques. Randomly allocating a subject to treatment or control groups makes sure that *everything else is equal*, hence we are really comparing apples with apples. Unfortunately, oftentimes we cannot perform a randomized control trial (RCT), out of technological, ethical, or other constraints. (We mentioned that forcing people to smoke via lottery draw is impossible to justify.) So, that's it, no RCT, no causal estimates? No! Methods like instrumental variables can help us to establish causality if we only have *observational data* (i.e. data generated not via experiment). That's reassuring, because in many settings this kind of data is the only thing we have. ## John Snow and the London Cholera Epidemic ```{r father-thames, fig.cap="Father Thames Introducing his Offspring to the Fair City of London, [Punch (1858)](https://www.bl.uk/collection-items/father-thames-introducing-his-offspring-to-the-fair-city-of-london-from-punch)",echo = FALSE} knitr::include_graphics("images/father-thames.jpg") ``` The 1853-1854 Cholera outbreak in London killed 616 people. Physician [John Snow](https://en.wikipedia.org/wiki/John_Snow) was able to use data collected during this period to demonstrate that the illness was water-borne, and not transmitted via air, as was widely believed at the time. In order to better appreciate this section, let's imagine the world of John Snow in 1853^[The following is based on @freedman1991]: ```{block, type='notel'} * It is not yet known that germs can cause disease (or indeed, that they exist). * Microscopes exist, but work at rather poor resolution. * Most human pathogens are not visible to the naked eye, and the isolation of such microbes is still several decades away. * The so-called *infection theory* (i.e. infection via *germs*) has some supporters, but the dominant idea is that disease, in general, results from [*miasmas*](https://en.wikipedia.org/wiki/Miasma_theory): very small, non-living poisonous particles that float in the air - basically rotting organic matter would emanate foul air, that caused disease. The figure below shows an illustration. ```
```{r miasma, fig.cap="Miasma in the Air. Robert Seymour - A Short History of the National Institutes of Health National Library of Medicine photographic archive.",echo = FALSE} knitr::include_graphics("images/Cholera_art.jpg",dpi = 75) ``` Snow hypothesized that the pathogen causing cholera was taken into the body via food or drink, multiplied and generated a poisonous substance causing the body to expel water, i.e. an extreme form of diarrhea. The active agent then would leave the human body via those excrements, and find their way back into the water supply, infecting the next victim. So, the question at the time was: is cholera a result of *miasmas* (foul, poisonous air), or a pathogen that was water-borne and infected new victims via excrements of former victims (the *infection theory*)? Snow conducted some impressive detective work tracking down exceptional cases that would refute the miasma theory. For example he documented that two adjacent appartment buildings, one hit by cholera and the other not, had different water supplies: the first building's supply was contaminated by runoffs from privies (toilets), while the second one had arguably cleaner water. He studied the wider water supply system of London, finding that several water providers took their water from the heavily polluted River Thames. During 1853-1854, John Snow drew a map (see figure \@ref(fig:snow-map)) that showed where the fatalities had occured. It became obvious that the cases clustered around the Broad Street pump. ```{r snow-map, fig.cap="John Snow's original map of the Broad Street pump. https://commons.wikimedia.org/wiki/File:Snow-cholera-map-1.jpg",echo = FALSE} knitr::include_graphics("images/snow-map.jpg") ``` The history goes that after observing the map and insisting with the local council, the handle of the water pump was removed, and the outbreak was ended. Alas, Snow himself showed that the epidemic was stopping anyway and the that removal of the pump handle was close to irrelevant. This can be seen in figure \@ref(fig:snow-TS). ```{r snow-TS,fig.cap="Time series of cholera deaths and timing of pump removal",warning=FALSE,echo = FALSE} plot(cholera::timeSeries()) ``` What seemed much more interesting to him were other observations, like for example: 1. He found that a large poorhouse in the Broad Street area had very few cholera cases. He observed that the poorhouse had its own well (no need for the inmates to go the public Broad Street pump). 1. There was a large brewery in the vicinity of the pump, whose workers did not die of cholera. The workers drank beer, and there was a private well on the premises. ### Mapping London's Water Supply A few years before the outbreak, Lambeth water company had decided to move its water intake point upstream along the Thames, beyond the main sewage discharge points. Two other companies, the Southwark and Vauxhall water companies, however, left their intake points where they were, i.e. downstream from the sewage discharges. Snows analysis of the data showed that cholera was more prevalent in the Southwark and Vauxhall serviced areas and largely had spared Lambeth. He was able to compile the data in table \@ref(tab:snow-tab9): ```{r snow-tab9,echo = FALSE} st9 <- data.frame(numhouses = c(40046,26107,256423), deaths = c(1263,98,1422), death1000 = c(315,37,59)) ``` Table: (\#tab:snow-tab9) John Snow's table IX | | Number of houses | Deaths from Cholera | Deaths per 1000 Houses | |----|:----------------:| :----------------: | :----------------: | |Southwark and Vauxhall | 40,046 | 1,263 | 315 | |Lambeth | 26,107 | 98 | 37 | |Rest of London | 256,423 | 1,422 | 59 | With table \@ref(tab:snow-tab9) in hand, Snow concluded that *if* Southwark and Vauxhall water companies had moved their water intakes upstream to where Lambeth water was taking in their supply, roughly 1,000 lives could have been saved. For proponents of the miasma theory, this was still not evidence enough, because there were also many factors that led to poor air quality in those areas. Of course Snow was proven right later on, when in 1884 Koch first isolated the cholera *vibrio*, basically confirming Snow's version of the story. But what is really interesting for us is how he was able to use his **non-experimental** data set to make his point. ### Snow's Model of Cholera Transmission Even though he never formally wrote it down in this way, we can formulate Snow's way of thinking about the issue in the following terms: * Suppose that $c_i$ takes the value 1 if individiual $i$ dies of cholera, 0 else. * Let $w_i = 1$ mean that $i$'s water supply is impure and $w_i = 0$ vice versa. Water purity is assessed with a technology that cannot detect small microbes. * Collect in $u_i$ all unobservable factors that impact $i$'s likelihood of dying from the disease: whether $i$ is poor, where exactly they reside, whether there is bad air quality in $i$'s surrounding, and other invidivual characteristics which impact the outcome (like genetic setup of $i$). With this, can write model \@ref(eq:snow-mod1): \begin{equation} c_i = \alpha + \delta w_i + u_i (\#eq:snow-mod1) \end{equation} John Snow could have used his data and assess the correlation between drinking pure water and cholera incidence, i.e. try to measure $Cor(c_i,w_i)$, or, which is similar, just run model \@ref(eq:snow-mod1) as a linear regression. There is a problem with this, however. As @deaton1997 says, > The people who drank impure water were also more likely to be poor, and to live in an environment contaminated in many ways, not least by the ‘poison miasmas’ that were then thought to be the cause of cholera. In other words, it does not make sense to compare someone who drinks pure water with someone with impure water, as model \@ref(eq:snow-mod1) proposes to do, because *all else is not equal*: pure water is correlated with being poor, living in bad area, bad air quality and so on - all factors that we encounter in $u_i$. This violates the crucial orthogonality assumption for valid OLS estimates, $E[u_i | w_i]=0$ in this context. Another way to say this, is that $Cov(w_i, u_i) \neq 0$, implying that $w_i$ is *endogenous* in equation \@ref(eq:snow-mod1): There are factors in $u_i$ that affect both $w_i$ and $c_i$, so we cannot reasonably say that *the effect of $w$ is that...*, because things in $u_i$ move at the same time as $w_i$ moves (and we can't see those things). So, the *miasma* theorists actually had a point. Let us condition equation \@ref(eq:snow-mod1) on either value $w$ might take: \begin{align} E[c_i | w_i = 1] &= \alpha + \delta + E[u_i | w_i = 1] \\ E[c_i | w_i = 0] &= \alpha + \phantom{\delta} + E[u_i | w_i = 0] \end{align} Simply differencing those two lines thus yields \begin{equation} E[c_i | w_i = 1] - E[c_i | w_i = 0] = \delta + \left\{ E[u_i | w_i = 1] - E[u_i | w_i = 0]\right\} \end{equation} and we said that it stands to reason that this last term $\left\{ E[u_i | w_i = 1] - E[u_i | w_i = 0]\right\}$ is not equal to zero, hence our regression estimate for $\delta$ would be biased by that quantity. ## Defining the IV Estimator John Snow did not know what an IV estimator was because it had not been described yet.^[In @angristkruegerIV you can read that Philipp (or his son Sewal, or both) Wright are widely attributed with this discovery in 1928] However, we can use the above setup to develop the idea. To get at this, it is useful to hear what John Snow has to say after he shows us his table IX, displayed in table \@ref(tab:snow-tab9) above: > [...] the mixing of the supply is of the most intimate kind. The pipes of each Company go down all the streets, and into nearly all the courts and alleys. [...] The experiment, too, is on the grandest scale. No fewer than three hundred thousand people of both sexes, of every age and occupation, and of every rank and station, from gentlefolks down to the very poor, were divided into two groups without their choice, and in most cases, without their knowledge; one group supplied with water containing the sewage of London, and amongst it, whatever might have come from the cholera patients, the other group having water quite free from such impurity. To back this up, he produced the following map showing which areas were served by which water company. As you can see from the legend, the purple areas denote those with mixed water supply. ```{r snow-supply,fig.cap="Snow's map of water supply in London",echo=FALSE} knitr::include_graphics("images/snow-supply.jpg",dpi = 100) ``` So, without knowing, Snow is proposing an **instrumental variable** $z_i$, the *identity of the water supplying company* to household $i$, which is highly correlated with the water purity $w_i$. However, following his remarks above, it seems to be uncorrelated with all the other factors in $u_i$, which worried us before: people in most cases didn't even know who supplied their water, as those decisions were taken years before. Very similar households, on either side of a street, may have had different water purity in their homes as a result of a different supplier.^[The formulation as an IV has been taken from [W. Greene's website](http://people.stern.nyu.edu/wgreene/Econometrics/Cholera-IV-Study.pdf)] Let's visualize this setup in a DAG to start with: ```{r IV-dag,warning = FALSE,message = FALSE,echo = FALSE,fig.cap="DAG for IV setup in Snow's study setting. $u$ affects both explanatory variable $w$ and outcome $c$ at the same time. $z$ affects the outcome *only through* its impact on $w$. Solid arrows are measurable with data, dashed arrows are not.",fig.height = 3 } library(ggdag) library(dplyr) coords <- list( x = c(z = 1, w = 3, u = 4, c = 5), y = c(z = 0, w = 0, u = 0.5, c = 0) ) dag <- dagify(c ~ w + u, w ~ z + u, coords = coords) dag %>% tidy_dagitty() %>% mutate(linetype = ifelse(name == "u", "dashed", "solid")) %>% ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_text() + geom_dag_edges(aes(edge_linetype = linetype), show.legend = FALSE) + theme_void() ``` You can see that outcome $c$ is affected by water purity $w$ and other factors $u$. The point of the DAG in figure \@ref(fig:IV-dag) is to show that $u$ affects both the outcome $c$ *and* the explanatory variable $w$ at the same time, and the conditional mean assumption $E[u_i | w_i]=0$ is violated (this is an implication of the arrow from $u$ to $w$). Now, $z$ affects *only* $w$ (it is *relevant* for $w$) and, furthermore, it is *not affected* by $u$ (it is *exogenous* to the outcome equation). Now, if you change the value of $z_i$ in this DAG, this will change $w_i$ (follow the solid arrow!), which will then change the outcome $c_i$. The key insight is that we can be sure that this change in $c_i$ had nothing to do with other factors $u_i$ - that's what our model assumes (no arrow from $u$ to $z$!). So, we can measure the part of the correlation between $w$ and $c$ that is *due to* correlation between $w$ and $z$, and obtain a *causal* effect! Spoiler alert: The formula for a one variable, one IV setting like this here is $$\frac{Cov(z,c)}{Cov(z,w)}.$$ The DAG is silent about the strength of each of the arrows. Whether any of the arrows is more or less important is a statistical question (i.e. we have to *measure* their strengths in data somehow). The usefulness of a DAG like this one is purely to think about and justify the model we have in mind, and for that purpose it is a very good tool. I would encourage you to draw one of those each time before you want to use IV analysis. In particular, your theory needs to spell out why there is no arrow from $u$ to $z$ - see Snow's argumentation above that water supply was close to randomly allocated to households in 1850 London. More formally, let's define the instrument as follows: \begin{align*} z_i &= \begin{cases} 1 & \text{if water supplied by Lambeth} \\ 0 & \text{if water supplied by Southwark or Vauxhall.} \\ \end{cases} \\ \end{align*} Here are the conditions for a valid instrument: ```{block, type="notel"} 1. **Relevance** or **First Stage**: Water purity is indeed a function of supplier identity. We want that $$E[w_i | z_i = 1] \neq E[w_i | z_i = 0]$$ i.e. the average water purity differs across suppliers. We can *verify* this condition with observational data. We want this effect to be reliably causal. 2. **Independence**: Whether a household has $z_i = 1$ or $z_i = 0$ is unrelated to $u$, hence *as good as random*. Whether we condition $u$ on certain values of $z$ does not change the result - we want $$E[u_i | z_i = 1] = E[u_i | z_i = 0].$$ 3. **Excludability** the instrument should affect the outcome $c$ *only* through the specified channel (i.e. via water purity $w$), and nothing else. ```
Point 3. is the difficult part, because there is no real test for it: we have to reason and argue to make the case that is a reasonable assumption. This is where Snow's citation from above comes into play: He reasons that water supply varies **randomly** over households, irrespective their unobservables $u$. The statement is that whatever factors are present in $u$, they are present in equal proportion in households with different $z$, because assignment of $z$ was **random**. So it is hard to imagine that the identity of the water company could affect $c$ through other channels (like, whether you are poor or not is *not* a function of $z$). We are now ready to define a simple IV estimator. Notice that conditioning \@ref(eq:snow-mod1) on values of $z$ yields \begin{align} E[c_i | z_i = 1] &= \alpha + \delta E[w_i | z_i = 1] + E[u_i | z_i = 1] \\ E[c_i | z_i = 0] &= \alpha + \delta E[w_i | z_i = 0] + E[u_i | z_i = 0] \end{align} which upon differencing both lines gives \begin{align} E[c_i | z_i = 1] - E[c_i | z_i = 0] &= \delta \left\{ E[w_i | z_i = 1] - E[w_i | z_i = 0]\right\} \\ &+ \underbrace{\left\{ E[u_i | z_i = 1] - E[u_i | z_i = 0] \right\}}_{=0 \text{ by Exogeneity Assumption}} \end{align} The IV estimator is then obtained by isolating $\delta$ and writing \begin{equation} \delta = \frac{E[c_i | z_i = 1] - E[c_i | z_i = 0]}{E[w_i | z_i = 1] - E[w_i | z_i = 0]} (\#eq:IV) \end{equation} Notice that this is only defined if the denominator is nonzero, i.e. the Relevance condition (point 1. above) holds. ### Computing the IV Estimate You remember from earlier chapters that equation \@ref(eq:IV) refers to a *population* parameter, i.e. *the true* value in an infinite population. To learn about it's value, we need to *estimate* it from data. We can use a simple sample analog of the population expectations, i.e. sample means. With some abuse of notation let's say that *$x \mapsto y$ means that $x$ is an estimate for $y$*: 1. $\overline{c}_1 \mapsto E[c_i | z_i = 1]$: the proportion of households supplied by Lambeth with cholera. 1. $\overline{w}_1 \mapsto E[w_i | z_i = 1]$: the proportion of households supplied by Lambeth with bad water. 1. $\overline{c}_0 \mapsto E[c_i | z_i = 0]$: the proportion of households not supplied by Lambeth with cholera. 1. $\overline{w}_0 \mapsto E[w_i | z_i = 0]$: the proportion of households not supplied by Lambeth with bad water. The estimator would then be \begin{equation} \hat{\delta} = \frac{\overline{c}_1 - \overline{c}_0}{\overline{w}_1 - \overline{w}_0} (\#eq:IVhat) \end{equation} In this special case where all involved variables $c,w,z$ are binary, the estimator is called the *Wald estimator*. Unfortunately we do not know the values of the above numbers, or at least I did not find them in readily available format (I think they are in Snow's book). So let's make some numbers up just for the sake of it. 1. $\overline{c}_1 = 0.002$: the proportion of households supplied by Lambeth with cholera. 1. $\overline{w}_1 = 0.1$: the proportion of households supplied by Lambeth with bad water. 1. $\overline{c}_0 = 0.315$: the proportion of households not supplied by Lambeth with cholera. 1. $\overline{w}_0 = 0.5$: the proportion of households not supplied by Lambeth with bad water. ```{r} delta = (0.002 - 0.315) / (0.1 - 0.5) ``` So, in this artificial dataset, we would have found an estimated **causal** effect of `r delta` of impure water on the likelihood of contracting cholera. We would write \begin{equation} \Delta \Pr(c = 1 | w ) = \alpha + \delta \times 1 - \alpha - \delta \times 0 = `r delta` \end{equation} so the probability of getting cholera is `r 100*round(delta,2)` percent higher, if you have impure water (i.e. if $w$ goes from 0 to 1). ```{block, type = "warningl"} **Summary**: IVs are a powerful tool to establish causality in contexts with observational data only and where we are concerned that the conditional mean assumption $E[u_i | x_i]=0$ is violated, hence, we cannot say *all else equal, as $x$ changes, $y$ changes like this and that*. Then we say that $x$ is *endogenous*. The key features of IV $z$ are that 1. $z$ is *relevant* for $x$. For example, in a simple regression of $z$ on $x$, we want $z$ to have considerable predictive power. We can *test* this condition in data. 2. We need a theory according to which is *reasonable* to assume that $z$ is *unrelated* to other unobservable factors that might impact the outcome. Hence, $z$ is *exogenous* to $u$, or $E[u | z] = 0$. This is an **assumption** (i.e. we can not test this with data). ``` ================================================ FILE: 11-IV2.Rmd ================================================ # IV Applications ```{r, echo = FALSE} library(modelsummary) gm = modelsummary::gof_map gm$omit <- TRUE gm$omit[gm$clean == "R2"] <- FALSE gm$omit[gm$clean == "Num.Obs."] <- FALSE gom = "p.value.|se_type|statistic.end|statistic.overid|statistic.weakinst" ``` An important term in economics are the *returns to schooling*, by which we mean the causal effect of education on later earnings. If you think about it, it's a crucial question for every single student (like yourself), if not even more so for a policy maker who needs to decide where to allocate budget spending on (education or other things?). One very famous and early study to estimate those returns to schooling was proposed by Jacob Mincer, and an equation of this kind was henceforth known as the *Mincer Equation* (we have encountered this equation before as a running example in chapter \@ref(linreg)). He measured $\log Y_i$, annual earnings for man $i$, $S_i$ his schooling (years spent studying), and $X_i$ his (potential) work experience (age minus years of schooling minus 6). The model can be drawn like this: ```{r mincer,warning = FALSE,message = FALSE,echo = FALSE,fig.cap="Jacob Mincer's model",fig.height = 3 } library(ggdag) library(dplyr) coords <- list( x = c(e = 1, x = 2, y = 3, s = 2), y = c(e=0, x = -.5, y = 0, s = 0.5) ) dag <- dagify(y ~ s, y ~ e, y ~ x, coords = coords) dag %>% tidy_dagitty() %>% mutate(linetype = ifelse(name == "e", "dashed", "solid")) %>% ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_text() + geom_dag_edges(aes(edge_linetype = linetype), show.legend = FALSE) + scale_x_continuous(limits = c(0,4))+ theme_void() ``` Hourly earnings are assumed to be affected by experience and schooling *only*. In terms of an equation, \begin{equation} \log Y_i = \alpha + \rho S_i + \beta_1 X_i + \beta_2 X_i^2 + e_i (\#eq:mincer) \end{equation} His results implied an estimate for $\rho$ of about 0.11, or an 11% earnings advantage for each additional year of education, given a certain level of experience. Notice that in the DAG in figure \@ref(fig:mincer), we explicitly drew other unobserved factors $e$ with *only* have an arrow directly into $y$. But is that a good model? Well, why would it not be? ## Ability Bias The model in \@ref(eq:mincer) compares earnings of men with certain schooling and work experience. The question to ask, if given those two controls, all else is equal? For a given value of $X$, are there more diligent and able workers out there? Do family connections vary across people with the same $X$? It seems quite likely that we'd answer yes. Well, then, all else is *not* equal, and we are in trouble. Because, again, our crucial identifying assumption for the linear model is violated, as $$E[e_i | S_i, X_i] \neq 0.$$ Our concern can be formalized by explicitly introducing *ability* $A$ as an (unobserved) factor into our model. That means we have now *two* unobservables - of course we can't tell them apart, so let's write them as a new unobservable factor $u_i = e_i + A_i$. Then we could visualize this new model as follows: ```{r mincer2,warning = FALSE,message = FALSE,echo = FALSE,fig.cap="Jacob Mincer's model with unobserved ability $A$. Given it's *unobserved* it is lumped together with all other unobservable factors in $e$, and we've called it $u = e + A$.",fig.height = 3 } coords <- list( x = c(e_A = 1, x = 2, y = 3, s = 2), y = c(e_A =0, x = -.5, y = 0, s = 0.5) ) dag <- dagify(y ~ s, y ~ e_A, s ~ e_A, y ~ x,coords = coords) d = dag %>% tidy_dagitty() %>% dag_label(labels = c("y" = "y","s" = "s","x" = "x","e_A"= "u=e+A")) %>% mutate(linetype = ifelse(label == "u=e+A", "dashed", "solid")) %>% ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_text(aes(label=label)) + geom_dag_edges(aes(edge_linetype = linetype), show.legend = FALSE) + scale_x_continuous(limits = c(0,4))+ theme_void() d ``` In figure \@ref(fig:mincer2), the unobserved factor $A$ influences *both* years of schooling and earnings on the labor market. For example, if we think for $A$ as something like *intelligence*, it might be that more intelligent students find it less painful to attend school (it's less costly for them in terms of effort), so they get more education, and also they earn higher wages because their intelligence is rewarded in the labor market. The same works if $A$ is related to family type and network. Suppose a family with high socio-economic status is also well connected. Then high $A$ could mean that the parents of $i$ know that education is a good signalling device (so they force $i$ to go to university, say), while at the same time their good network means that high $A$ will mean a good job and hence earnings. We would write in terms of an equation \begin{equation} \log Y_i = \alpha + \rho S_i + \beta_1 X_i + \beta_2 X_i^2 + \underbrace{u_i}_{A_i + e_i} (\#eq:ability) \end{equation} Sometimes these considerations do not matter greatly, and the (biased) OLS estimate is close the causal IV estimate. But in other cases, we might be very far from the truth with OLS, even inferring the wrong sign of an effect. Let's look at an example! ## Birthdate is as good as Random In an influential study, @angristkrueger address the above issues related to the ability bias in Mincer's equation by constructing an IV which encodes the birth date of a given student. The idea is that given certain features of the school system, children born shortly after a certain cutoff date will start school a year later than their peers who are a bit older than they are. For example, suppose it is mandated that all children who reach the age of 6 by 31st of december 2021 are required to enroll in the first grade of school in september 2021. Then someone born in September 2015 (i.e. 6 years prior) will be 5 years and 3/4 by the time they start school, while someone born on the 1st of January 2016 will be 6 and 3/4 years when *they* enter school in september 2022. Furthermore, the legal dropout age in the US is 16, so by the time those pupils may decide to stop school, they have been exposed to different amounts of schooling. All of this means that an IV defined by *quarter of birth of person $i$* will affect the outcome *earnings* through it's effect on more schooling - keeping other factors (in particular $A$!) constant across values of the IV. What's the implication for our model? ```{r ak-mod,echo = FALSE,fig.cap="Angrist and Krueger's IV in to tackle ability bias.",fig.height = 3 } coords <- list( x = c(e_A = 1, z = 1, y = 3, s = 2), y = c(e_A =0, z = 0.5, y = 0, s = 0.5) ) dag <- dagify(y ~ s, y ~ e_A, s ~ e_A, s ~ z,coords = coords) d = dag %>% tidy_dagitty() %>% dag_label(labels = c("y" = "y","s" = "s","z" = "z","e_A"= "u=e+A")) %>% mutate(linetype = ifelse(label == "u=e+A", "dashed", "solid")) %>% ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_text(aes(label=label)) + geom_dag_edges(aes(edge_linetype = linetype), show.legend = FALSE) + scale_x_continuous(limits = c(0,4))+ theme_void() d ``` In the DAG for @angristkrueger's model in \@ref(fig:ak-mod) we see that the IV directly impacts the endogenous explanatory variable $s$, but is itself independent of $u$ - we argued that $A$ is equally distributed across different birth quarters $z$ (birth date is almost random). Let us now formulate the following two-stage procedure: 1. We estimate a **first stage model** which uses only exogenous variables (like $z$) to explain our endgenous regressor $s$. 2. We then use the first stage model to *predict* values of $s$ in what is called the **second stage** or the **reduced form** model.^[It's called reduced form because this second equation is supposed to be derived from a true underlying structural model.] Performing this procedure is supposed to take out any impact of $A$ in the correlation we observe in our data between $s$ and $y$. This estimation technique is called the **Two stage least squares** estimator, or 2SLS for short. The great virtue is that in the first stage we could have any number of exogenous variables helping to predict our exogenous $s$ (here we have just one - quarter of birth.) In terms of equations, we could write the following: \begin{align} \text{1. Stage: }s_i &= \alpha_0 + \alpha_1 z_i + \eta_i (\#eq:2SLS1)\\ \text{2. Stage: }y_i &= \beta_0 + \beta_1 \hat{s}_i + u_i (\#eq:2SLS2) \end{align} where the $\hat{s}_i$ means to insert the *predicted* value from the first stage for $i$'s observed $s_i$ in the second stage regression. We can write down the conditions for a valid IV $z$ in this context: ```{block, type = "warningl"} **Conditions for a valid Instrument in this simple 2SLS setup**: 1. Relevance of the IV: $\alpha_1 \neq 0$ 1. Independence (IV assignment as good as random): $E[\eta | z] = 0$ 1. Exogeneity (our exclusion restriction): $E[u | z] = 0$ ``` ### Data on birth quarter and wages Let's load the data and look at a quick summary^[Code in this section comes from the great [mastering metrics with R](https://jrnold.github.io/masteringmetrics/) by J Arnold 👏 🙏]: ```{r ak-data} data("ak91", package = "masteringmetrics") # library(modelsummary) # loaded already for me datasummary_skim(data.frame(ak91),histogram = TRUE) ``` We convert quarter of birth to a factor: ```{r} ak91 <- mutate(ak91, qob_fct = factor(qob), q4 = as.integer(qob == "4"), yob_fct = factor(yob)) # get mean wage by year/quarter ak91_age <- ak91 %>% group_by(qob, yob) %>% summarise(lnw = mean(lnw), s = mean(s)) %>% mutate(q4 = (qob == 4)) ``` Let's reproduce their first figure now on education as a function of quarter of birth! ```{r ak91-age,fig.cap = "Reproducing figure 1 from @angristkruegerIV"} ggplot(ak91_age, aes(x = yob + (qob - 1) / 4, y = s )) + geom_line() + geom_label(mapping = aes(label = qob, color = q4)) + guides(label = FALSE, color = FALSE) + scale_x_continuous("Year of birth", breaks = 1930:1940) + scale_y_continuous("Years of Education", breaks = seq(12.2, 13.2, by = 0.2), limits = c(12.2, 13.2)) + theme_bw() ``` In figure \@ref(fig:ak91-age) we see first that there was a trend in getting more and more education as time passed. Secondly, and more importantly here, is that for almost all birth years in the sample, the group born in quarter 4 has the highest value for years of education! So what we said above about the instutional rules of school attendance in the US seems to be born out in this dataset. What about earnings for those groups? ```{r ak91-wage,fig.cap = "Reproducing figure 2 from @angristkruegerIV"} ggplot(ak91_age, aes(x = yob + (qob - 1) / 4, y = lnw)) + geom_line() + geom_label(mapping = aes(label = qob, color = q4)) + scale_x_continuous("Year of birth", breaks = 1930:1940) + scale_y_continuous("Log weekly wages") + guides(label = FALSE, color = FALSE) + theme_bw() ``` Figure \@ref(fig:ak91-wage) does not show a long running trend in earnings, so on average we'd say an hourly wage of 5 Dollars 90 per week. But, again, the group born in the fourth quarter seems special: In many cases they earn the highest or close to highest wage if compared to the other 3 groups in their birthyear. So, there really seems to be a relationship between quarter of birth and later in life earnings! Let us now construct an IV estimator, which will allow us to relate the sawtooth pattern in figure \@ref(fig:ak91-age) to the one in \@ref(fig:ak91-wage). We will start out with using just *born in fourth quarter* as our IV. ### Running IV estimation in `R` There are several possibilities to run IV estimation in `R`. We will use the `iv_robust` function from the `estimatr` package.^[the *robust* here refers to the fact that the `estimatr` package by default chooses formulae to compute standard errors which are correcting for heteroskedasticity - we have encountered this term before in \@ref(violating). See details [here](https://declaredesign.org/r/estimatr/articles/mathematical-notes.html)] Let's estimate a simple OLS version (subject to ability bias), the first stage and second stages, and the final 2SLS estimate: ```{r} mod <- list() mod$ols <- lm(lnw ~ s, data = ak91) mod[["first stage"]] <- lm(s ~ q4, data = ak91) # IV: born in q4 is TRUE? ak91$shat <- predict(mod[["first stage"]]) mod[["second stage"]] <- lm(lnw ~ shat, data = ak91) mod$`2SLS` <- estimatr::iv_robust(lnw ~ s | q4, data = ak91 ) # IV: born in q4 is TRUE? ``` Let's look at those models next to each other in table \@ref(tab:ms1): ```{r ms1,echo = FALSE} msummary(models = mod, stars = TRUE, statistic = 'std.error', gof_omit = 'DF|Deviance|AIC|BIC|R2|p.value|se_type|statistic|Log.Lik.|Num.Obs.|N', title = "OLS, first and sceond stages as well as 2SLS estimates for Angrist and Krueger (1991)") ``` Table \@ref(tab:ms1) contains a lot of information, so let's go column-wise: 1. The column labelled **ols** is the basic earnings equation similar to Mincer's model (without experience). We are worried about bias from the omitted variable *ability*, but we note that here we estimate a 7% higher wage for each additional year of schooling. 2. The next column is the first stage, i.e. the estimates for $\alpha$ in equation \@ref(eq:2SLS1). Remember we require that $\alpha_1 \neq 0$. That seems to be the case here (p-value very small). 3. Then we run the second stage model with the predicted values $\hat{s}$ from the first stage, i.e. we estimate the $\beta$s in \@ref(eq:2SLS2). You should compare `s` and `shat` in the first and third column. 4. Finally, we perform first and second stag e estimation in one go (you would usually go down this route directly) with 2SLS. You should compare `shat` from the second stage with the `s` estimate from the 2SLS model! The reason you should always go directly to something like `iv_robust` is that this procedure handles computation of standard errors correctly. In other words, the displayed standard error in the second stage for `shat` (0.03) is not taking into account that we estimated `shat` itself in a previous step - `iv_robust` does (note the small difference to 0.028). ### Additional Control Variables We saw in figure \@ref(fig:ak91-age) that there is a clear time trend in years of schooling. There are also business-cycle fluctuations in earnings, even if we were not able to see them from the graph above. It is probably a good idea to control for calendar year in order to guard against any time effects in our results. Also, we can use more than one IV! Here is how: ```{r} mod$ols_yr <- update(mod$ols, . ~ . + yob_fct) # just update previous model mod[["2SLS_yr"]] <- estimatr::iv_robust(lnw ~ s + yob_fct | q4 + yob_fct, data = ak91 ) # add exogenous vars on both sides of | ! mod[["2SLS_all"]] <- estimatr::iv_robust(lnw ~ s + yob_fct | qob_fct + yob_fct, data = ak91 ) # use all quarters as IVs # here is how to make the table: rows <- data.frame(term = c("Instruments","Year of birth"), ols = c("none","no"), SLS = c("Q4","no"), ols_yr = c("none","yes"), SLS_yr = c("Q4","yes"), SLS_all = c("All Quarters","yes") ) names(rows)[c(3,5,6)] <- c("2SLS","2SLS_yr","2SLS_all") modelsummary::msummary(models = mod[c("ols","2SLS","ols_yr","2SLS_yr","2SLS_all")], statistic = 'std.error', gof_omit = 'DF|Deviance|AIC|BIC|R2|p.value|se_type|statistic|Log.Lik.|Num.Obs.|N', title = "Adding Year as control, and more IVs", add_rows = rows, coef_omit = 'yob_fct') ``` ## IV Mechanics {#IV-mech} Let's now look a little closer under the hood of our simple IV estimator. We want to understand how inference of IV relates to OLS inference, and what we can say about *weak* instruments, i.e. IVs with small predictive power in the first stage. Let's go back to our simple linear model $$ y = \beta_0 + \beta_1 x + u (#eq:iv0) $$ where we think that $Cov(x,u) \neq 0$, hence, that $x$ is *endogenous* in this equation. By the way, IV estimation will work whether or not $Cov(x,u) \neq 0$, but we should prefer OLS if $x$ is exogenous, as should become clear soon. We now know that the conditions under which IV $z$ will deliver consistent estimates are the following: 1. **first stage** or **relevance**: $Cov(z,x) \neq 0$ 2. **IV exogeneity**: $Cov(z,u) = 0$: the IV is exogenous in the outcome equation. To reiterate, condition 2 here calls for $z$ to have no partial effect on $y$, after $x$ and other omitted variables have been considered (they are in $u$), hence, that $z$ is uncorrelated with $u$. Figure \@ref(fig:IV-dag2) shows a valid IV in panel A and an IV which violates condition 2 in panel B. ```{r IV-dag2,warning = FALSE,message = FALSE,echo = FALSE,fig.cap="A valid IV (A) and one where the exogeneity assumption is violated (B).",fig.height = 3 } coords <- list( x = c(z = 1, x = 3, u = 4, y = 5), y = c(z = 0, x = 0, u = 0.5, y = 0) ) dag1 <- dagify(y ~ x + u, x ~ z + u, coords = coords) d1 = dag1 %>% tidy_dagitty() %>% mutate(linetype = ifelse(name == "u", "dashed", "solid")) %>% ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_text() + geom_dag_edges(aes(edge_linetype = linetype), show.legend = FALSE) + theme_void() dag2 <- dagify(y ~ x + u, x ~ z + u, z ~ u, coords = coords) d2 = dag2 %>% tidy_dagitty() %>% mutate(linetype = ifelse(name == "u", "dashed", "solid")) %>% ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_text() + geom_dag_edges(aes(edge_linetype = linetype), show.legend = FALSE) + theme_void() cowplot::plot_grid(d1,NULL,d2,nrow = 1 , rel_widths = c(1, 0.15, 1) , labels = c("(A)", "", "(B)")) ``` Let us now discuss how conditions 1. and 2. are helpful in *identifying* parameter $\beta_1$ above. By this we mean our ability to express $\beta_1$ in terms of population moments, which we can estimate from a sample of data. We start by computing the covariance of the instrument $z$ with outcome $y$. \begin{align} Cov(z,y) &= Cov(z, \beta_0 + \beta_1 x + u) \\ &= \beta_1 Cov(z,x) + Cov(z,u) \end{align} Under condition 2. above (*IV exogeneity*), we have $Cov(z,u)=0$, hence $$ Cov(z,y) = \beta_1 Cov(z,x) $$ and under condition 1. (*relevance*), we have $Cov(z,x)\neq0$, so that we can divide the equation through to obtain $$ \beta_1 = \frac{Cov(z,y)}{Cov(z,x)}. $$ This shows that the parameter $\beta_1$ is *identified* via population moments $Cov(z,y)$ and $Cov(z,x)$. What is more, we can *estimate* those moments via their *sample analogs*, hence we have as an IV estimator this expression, where we just *plug in* the sample estimators for the population moments: $$ \hat{\beta}_1 = \frac{\sum_{i=1}^n (z_i - \bar{z})(y_i - \bar{y})}{\sum_{i=1}^n (z_i - \bar{z})(x_i - \bar{x})} (#eq:iv-estim) $$ The corresponding intercept estimate $\hat{\beta}_0 = \bar{y} - \hat{\beta}_1 \bar{x}$ is identical to before (modulo using \@ref(eq:iv-estim)). Given both assumptions 1. and 2. are satisfied, we say that *the IV estimator is consistent for $\beta_1$*. This can also be written as $$ \text{plim}(\hat{\beta}_1) = \beta_1 $$ meaning that, as the sample size $n$ increases, the **probability limit** (plim) of the estimator $\hat{\beta}_1$ is the true value $\beta_1$.^[More precisely, we say that a sequence of random variables indexed by sample size $n$, ${X_n}$ say, *converges in probability* to the random variable $X$, if for all $\varepsilon > 0$, $$ \lim_{n \to \infty} \Pr \left(|X_n - X | > \varepsilon \right) = 0 $$ ] ### IV Inference Let us extend the homoskedasticity assumption to $z$, such that $E(u^2|z) = \sigma^2$, implying that the asymptotic (i.e. as the sample size gets very large) variance of the IV slope estimator is given by $$ Var(\hat{\beta}_{1,IV}) = \frac{\sigma^2}{n \sigma_x^2 \rho_{x,z}^2} (#eq:iv-var) $$ where $\sigma_x^2$ is the population variance of $x$, $\sigma^2$ the one of $u$, and $\rho_{x,z}$ is the population correlation between $x$ and $z$ - a measure of *how strongly* our IV and endogenous variable $x$ are correlated in the population. You can see 2 important things in equation \@ref(eq:iv-var): 1. Without the term $\rho_{x,z}^2$ in the denominator, this is identical to the variance of the OLS slope estimator. 2. As with the variance of the OLS slope estimator, as sample size $n$ increases, the variance decreases. It is convenient to replace $\rho_{x,z}^2$ with $R_{x,z}^2$, i.e. the R-squared of a regression of $x$ on $z$ - in a single regressor model we have this exact correspondence. It is convenient because we rewrite the variance of the IV slope now as $$ Var(\hat{\beta}_{1,IV}) = \frac{\sigma^2}{n \sigma_x^2 R_{x,z}^2} $$ 1. Given $R_{x,z}^2 < 1$ in most real life situations, we have that $Var(\hat{\beta}_{1,IV}) > Var(\hat{\beta}_{1,OLS})$ almost certainly. 1. The higher the correlation between $z$ and $x$, the closer their $R_{x,z}^2$ is to 1. With $R_{x,z}^2 = 1$ we get back to the OLS variance. This is no surprise, because that implies that in fact $z = x$. So, if you have a valid, exogenous regressor $x$, you should *not* perform IV estimation using $z$ to obtain $\hat{\beta}$, since your variance will be unnecessarily large. #### Returns to Education for Married Women Consider the following model for married women's wages: $$ \log wage = \beta_0 + \beta_1 educ + u $$ Let's run an OLS on this, and then compare it to an IV estimate using *father's education*. Keep in mind that this is a valid IV $z$ if 1. *fatheduc* and *educ* are correlated 2. *fatheduc* and $u$ are not correlated. ```{r mroz1} data(mroz,package = "wooldridge") mods = list() mods$OLS <- lm(lwage ~ educ, data = mroz) mods[['First Stage']] <- lm(educ ~ fatheduc, data = subset(mroz, inlf == 1)) mods$IV <- estimatr::iv_robust(lwage ~ educ | fatheduc, data = mroz) modelsummary::modelsummary(mods, gof_map = gm, gof_omit = gom, title = "Mroz female labor supply and wage data.") ``` The results in table \@ref(tab:mroz1) show in the first column that an additional year of education implies an 11% increase in annual wages for women. This is a standard OLS estimator which be biased because of *ability bias*. In the second column we show the first stage of the IV procedure. We see that *fatheduc* is indeed a statistically significant predictor of $educ$: Each additional year of father's education increases women's education by more than a quarter of a year (0.269). Also important, we observe that the $R^2$ here is about 17%. Turning to the final IV estimate in the third column, we can see that using *fatheduc* as an IV reduces the return to education by about half to 5.9%! This result *suggests* that OLS is biased upwards (for example by ability bias). But let's compare the standard errors of OLS and IV estimates, which are 0.014 for OLS vs 0.037 for IV. This can be seen in figure \@ref(fig:se-plot). You can clearly see that the standard errors of both estimators overlap, hence from this alone we cannot conclude they are different (we need a special statistical test to decide this). ```{r se-plot,echo = FALSE,fig.cap="OLS vs IV Standard Errors: The dots represent the point estimates, and the solid vertical lines the standard error for both estimators."} coefs_ols = broom::tidy(mods$OLS, conf.int = TRUE) coefs_IV = broom::tidy(mods$IV, conf.int = TRUE) bind_rows( coefs_ols %>% filter(term == "educ") %>% mutate(estimator = "OLS"), coefs_IV %>% filter(term == "educ") %>% mutate(estimator = "IV") ) %>% ggplot(aes(x=estimator, y=estimate, ymin=conf.low, ymax=conf.high)) + geom_hline(yintercept = 0.0, color = "red", size =1.2) + geom_pointrange() + theme_bw() ``` ### IV with a *Weak* Instrument We have seen that IV will produce consistent estimates under our stated assumptions. However, even under valid assumption, we get large IV standard errors if the the correlation between IV and endogenous $x$ is small. What is even worse is that *even if* we have only very small correlation between $z$ and $u$, so that we might *almost* be happy to assume exogeneity, a small corrleation between $x$ and $z$ can produce **inconsistent** estimates. To see this, consider the probability limit of the IV estimator again $$ \text{plim}(\hat{\beta}_{1,IV}) = \beta_1 + \frac{Cor(z,u)}{Cor(z,x)} \cdot \frac{\sigma_u}{\sigma_x} $$ The interesting part here involves the correlation terms. *Even if* $Cor(z,u)$ is very small, a **weak instrument**, i.e. one with only a small absolute value for $Cor(z,x)$ will blow up this second term in the probability limit. This would mean that even with a very big sample size $n$, our estimator would **not converge** to the true population parameter $\beta_1$, because we are using a weak instrument. To illustrate this point, let's assume we want to look at the impact of number of packs of cigarettes smoked per day by pregnant women (*packs*) on the birthweight of their child (*bwght*): $$ \log(bwght) = \beta_0 + \beta_1 packs + u $$ We are worried that smoking behavior is correlated with a range of other health-related variables which are in $u$ and which could impact the birthweight of the child - think of diet, physical exercise, and other lifestyle choices. So we look for an IV. Suppose we use the price of cigarettes (*cigprice*), assuming that the price of cigarettes is uncorrelated with factors in $u$ - the price of cigarettes would not impact birthweight (apart from through its effect on smoking behaviour, of course). Let's run the first stage of *cigprice* on *packs* and then let's show the 2SLS estimates: ```{r bw} data(bwght, package = "wooldridge") mods <- list() mods[["First Stage"]] <- lm(packs ~ cigprice, data = bwght) mods[["IV"]] <- estimatr::iv_robust(log(bwght) ~ packs | cigprice, data = bwght) modelsummary(mods, gof_map = gm, gof_omit = gom, title = "IV regression with weak instrument *cigprice*") ``` The first column of table \@ref(tab:bw) shows that the first stage is *very* weak. The partial effect of *cigprice* on *packs* smoked is zero! People don't seem to care a great deal about the price of cigarettes (at least in the range of price variation observed in this dataset). The $R^2$ of that first stage is thus zero. What do we get if we use that IV nonetheless in a 2SLS estimation as in column 2? We get a huge coefficient of unexpected sign on *packs* (smoking more increases birthweight? 🤔), with very large standard error, so statistically speaking, we cannot distinguish this from zero. What is more important, however, is that even if they *were* significant, the estimates of column 2 are **invalid**. The *relevance* of the IV condition is clearly not satisfied, hence, invalid approach. ⛔ ================================================ FILE: 12-panel.Rmd ================================================ # Panel Data ## Crime Rate vs Probability of Arrest This part draws heavily on [Nick C Huntington-Klein's](http://nickchk.com) outstanding [slides](https://github.com/NickCH-K/EconometricsSlides). 🙏 Up until now we have dealt with data that looked like the following, where `County` is the idendifier for a county, `CrimeRate` is the number of crimes committed by person, and `ProbofArrest` is the probability of arrest, given crime committed: ```{r,message=FALSE,warning=FALSE,echo = TRUE} library(dplyr) library(ggplot2) data(crime4,package = "wooldridge") crime4 %>% filter(year == 81) %>% arrange(county,year) %>% select(county, crmrte, prbarr) %>% rename(County = county, CrimeRate = crmrte, ProbofArrest = prbarr) %>% slice(1:5) %>% knitr::kable(align = "ccc") ``` We would have a unit identifier (like `County` here), and some observables on each unit. Such a dataset is usually called a **cross-sectional** dataset, providing one single snapshot view about variables from a study population at a single point in time. Each row, in other words, was one *observation*. **Panel data**, or **longitudinal** datasets, on the other hand, also index units over *time*. In the above dataset, for example, we could record crime rates in each county *and in each year*: ```{r,echo = FALSE} crime4 %>% select(county, year, crmrte, prbarr) %>% arrange(county,year) %>% rename(County = county, Year = year, CrimeRate = crmrte, ProbofArrest = prbarr) %>% slice(1:9) %>% knitr::kable(align = "ccc") ``` Here each unit $i$ (e.g. county `1`) is observed *several times*. Let's start by looking at the dataset as a single cross section (i.e. we forget about the $t$ index and treat each observation as independent over time) and investigate the relationship between crime rates and probability of arrest in counties number `1,3,23,145`: ```{r crime1,echo = TRUE,fig.cap = "Probability of arrest vs Crime rates in the cross section",message = FALSE} css = crime4 %>% filter(county %in% c(1,3,145, 23)) # subset to 4 counties ggplot(css,aes(x = prbarr, y = crmrte)) + geom_point() + geom_smooth(method="lm",se=FALSE) + theme_bw() + labs(x = 'Probability of Arrest', y = 'Crime Rate') ``` We see an upward-sloping regression line, so it seems that the higher the crime rate, the higher the probability of arrest. In particular, we'd get: ```{r} xsection = lm(crmrte ~ prbarr, css) coef(xsection)[2] # gets slope coef ``` ```{r,echo = FALSE} xsection_p = round(predict(xsection,newdata = data.frame(prbarr = c(0.2,0.3))),3) ``` such that we'd associate an increase of 10 percentage points in the probability of arrest (`prbarr` goes from 0.2 to 0.3) with an increase in crime rate from `r xsection_p[1]` to `r xsection_p[2]`, or a `r round(100 * diff(xsection_p) / xsection_p[1],2)` percent increase. Ok, but what does that *mean*? Literally, it tells us counties with a higher probability of being arrested also have a higher crime rate. So, does it mean that as there is more crime in certain areas, the police become more efficient at arresting criminals, and so the probability of getting arrested on any committed crime goes up? What does police efficiency depend on? Does the poverty level in a county matter for this? The local laws? 🤯 wow, there seem to be too many things left out of this simple picture. It's impossible to decide whether this estimate *makes sense* or not like this. A DAG to the rescue! ```{r cri-dag,echo = FALSE,message = FALSE,fig.cap="DAG to answer *what causes the local crime rate?*"} library(ggdag) coords <- list( x = c(ProbArrest = 1,LawAndOrder = 1, Police = 1.5, CivilRights = 3,Poverty = 3, CrimeRate = 5, LocalStuff = 5), y = c(ProbArrest = 1,LawAndOrder = 4, Police = 2.5, CivilRights = 2,Poverty = 4, CrimeRate = 1, LocalStuff = 4) ) dagify(CrimeRate ~ ProbArrest, CrimeRate ~ LocalStuff, CrimeRate ~ Poverty, CrimeRate ~ CivilRights, ProbArrest ~ LocalStuff, Poverty ~ LocalStuff, ProbArrest ~ Poverty, ProbArrest ~ LawAndOrder, ProbArrest ~ Police, ProbArrest ~ LawAndOrder, CivilRights ~ LawAndOrder, Police ~ LawAndOrder, labels = c("CrimeRate" = "Crime Rate", "ProbArrest" = "ProbArrest", "LocalStuff" = "LocalStuff", "Poverty" = "Poverty", "Police" = "Police", "CivilRights" = "CivilRights", "LawAndOrder" = "LawAndOrder" ), exposure = "ProbArrest", outcome = "CrimeRate", coords = coords) %>% ggdag(text = FALSE, use_labels = "label") + ggtitle("What causes the Crime Rate in County i?") + theme_dag() ``` In figure \@ref(fig:cri-dag) we've written `LawAndOrder` for how committed local politicians are to *law and order politics*, and `LocalStuff` for everything that is unique to a particular county apart from the things we've listed. So, at least we can appreciate to full problem now, but it's still really complicated. Let's try to think about *at which level* (i.e. county or time) each of those factors *vary*: * `LocalStuff` are things that describe the County, like geography, and other persistent features. * `LawAndOrder` and how many `CivilRights` one gets might change a little from year to year, but not very drastically. Let's assume they are fixed characteristics as well. * `Police` budget and the `Poverty` level vary by county and by year: an elected politician has some discretion over police spending (not too much, but still), and poverty varies with the national/global state of the economy. You will often hear the terms *within* and *between* variation in panel data contexts. If we think of our data as classified into groups of $i$ (i.e., counties), the *within* variation refers to things that change *within each group* over time: here we said police budgets and poverty levels would change within each group and over time. On the other hand, we said that `LocalStuff`, `LawAndOrder` and `CivilRights` were persistent features of each group, hence they would *not* vary over time (or *within* the group) - they would differ only across or **between** groups. Let's try to separate those out visually! ```{r,echo = FALSE,message = FALSE} pcolor = css %>% group_by(county) %>% mutate(label = case_when( crmrte == max(crmrte) ~ paste('County',county), TRUE ~ NA_character_ ), mcrm = mean(crmrte), mpr = mean(prbarr)) %>% ggplot(aes(x = prbarr, y = crmrte, label = label)) + geom_point(aes(color = factor(county))) + theme_bw() + geom_smooth(method = "lm", se=FALSE) + labs(x = 'Probability of Arrest', y = 'Crime Rate', color = "County") pcolor ``` That looks intriguing! Let's add the mean of `ProbofArrest` and `CrimeRate` for each of the counties to that plot, in order to show the *between* county variation: ```{r,echo = FALSE,fig.height = 3,warning = FALSE,message = FALSE} p1 = css %>% group_by(county) %>% mutate(label = case_when( crmrte == max(crmrte) ~ paste('County',county), TRUE ~ NA_character_ ), mcrm = mean(crmrte), mpr = mean(prbarr)) %>% ggplot(aes(x = prbarr, y = crmrte, label = label)) + geom_point(aes(color = factor(county))) + theme_bw() + # geom_smooth(method = "lm", se=FALSE) + scale_x_continuous(limits = c(0.1,0.43)) + scale_y_continuous(limits = c(0.01,0.041)) + labs(x = 'Probability of Arrest', y = 'Crime Rate', color = "County") + # scale_color_manual(values = c('black','blue','red','purple')) geom_point(aes(x = mpr, y = mcrm,color = factor(county)), size = 20, shape = 3) + annotate(geom = 'text', x = .3, y = .02, label = 'Means Within Each County', color = 'darkorange', size = 14/.pt) + guides(color = FALSE, labels = FALSE) # p11 = css %>% # ggplot(aes(x = prbarr, y = crmrte)) + geom_smooth(method = "lm", se = FALSE) p2 = css %>% group_by(county) %>% mutate(label = case_when( crmrte == max(crmrte) ~ paste('County',county), TRUE ~ NA_character_ ), mcrm = mean(crmrte), mpr = mean(prbarr)) %>% ggplot(aes(x = mpr, y = mcrm)) + theme_bw() + geom_smooth(method = "lm",se = FALSE) + geom_point(size = 20, shape = 3, aes(color = factor(county))) + scale_x_continuous(limits = c(0.1,0.43)) + scale_y_continuous(limits = c(0.01,0.041)) + labs(x = 'Probability of Arrest', y = 'Crime Rate') + guides(color = FALSE, labels = FALSE) cowplot::plot_grid(p1,p2,axis = "tb") ``` Simple OLS on the cross section (i.e. not taking into account the panel structure) seems to recover only the *between* group differences. It fits a line to the group means. Well this considerably simplifies our DAG from above! Let's collect all group-specific time-invariant features in the factor `County` - we don't really care about what they all are, because we can net the group effects out of the data it seems: ```{r cri-dag2,echo = FALSE,message = FALSE,fig.cap="DAG to answer *what causes the local crime rate?*"} coords <- list( x = c(ProbArrest = 1,Poverty = 1, Police = 1.5, County = 3, CrimeRate = 4), y = c(ProbArrest = 1,Police = 2.5, Poverty = 4, CrimeRate = 1, County = 4) ) dagify(CrimeRate ~ ProbArrest, CrimeRate ~ County, CrimeRate ~ Poverty, ProbArrest ~ Poverty, ProbArrest ~ County, Poverty ~ County, ProbArrest ~ Police, Police ~ County, labels = c("CrimeRate" = "Crime Rate", "ProbArrest" = "ProbArrest", "County" = "County", "Poverty" = "Poverty", "Police" = "Police"), exposure = "ProbArrest", outcome = "CrimeRate", coords = coords) %>% ggdag(text = FALSE, use_labels = "label") + theme_dag() ``` So, controlling for `County` takes care of all factors which do *not* vary over time within each unit. Police and Poverty will have a specific County-specific mean value, but there will be variation over time. We will basically be able to compare each county with itself at different points in time. ## Panel Data Estimation with `R` We have now seen several instances of problems with simple OLS arising from *unobserved variable bias*. For example, if the true model read $$ y_i = \beta_0 + \beta_1 x_i + c_i + u_i $$ with $c_i$ unobservable and potentially correlated with $x_i$, we were in trouble because the orthogonality assumption $E[u_i+c_i|x_i]\neq 0$ ($u_i+c_i$ is the total unobserved component). We have seen such an example where $c=A_i$ and $x=s$ was schooling and we were worried about *ability bias*. One solution we discussed was to find an IV which is correlated with schooling (quarter of birth) - but not with ability (we thought ability is equally distributed across birthdates). Today we'll look at solutions when we have *more than a single* observation for each unit $i$. To be precise, let's put down a basic unobserved effects model like this: $$ y_{it} = \beta_1 x_{it} + c_i + u_{it},\quad t=1,2,...T (\#eq:panel) $$ The object of interest here is $c_i$, called the *individual fixed effect*, *unobserved effect* or *unobserved heterogeneity*. The important thing to note is that it is fixed over time (ability $A_i$ for example). ### Dummy Variable Regression The simplest approach is arguably this: we could take the equation literally and estimate a linear model where we include a dummy variable for each $i$. This is closest to what we said above is *controlling for county* - that's exactly what we do here. You can see in \@ref(eq:panel) that each $i$ has basically their own intercept $c_i$, so this works. In `R` you achieve this like so: ```{r} mod = list() mod$dummy <- lm(crmrte ~ prbarr + factor(county), css) # i is the unit ID broom::tidy(mod$dummy) ``` Here is what we are talking about in a picture: ```{r dummy,echo = FALSE,message = FALSE} # not sure that's helpful css$pred <- predict(mod$dummy) # get predicted line pcolor = css %>% group_by(county) %>% ggplot(aes(x = prbarr, y = crmrte, color =factor(county) )) + geom_point() + geom_line(aes(y = pred )) + theme_bw() + # geom_smooth(method = "lm", se=FALSE) + labs(x = 'Probability of Arrest', y = 'Crime Rate', color = "County") pcolor ``` It's evident that *within* each county, there is a negative relationship. The dummy variable regression allows for different intercepts (county `1` is be the reference group), and one unique slope coefficient $\beta$. (you observe that the lines are parallel). You can see from this by looking at the picture that what the dummies are doing is shifting their line down from the reference group 1. ### First Differencing If we only had $T=2$ periods, we could just difference both periods, basically leaving us with \begin{align} y_{i1} &= \beta_1 x_{i1} + c_i + u_{i1} \\ y_{i2} &= \beta_1 x_{i2} + c_i + u_{i2} \\ & \Rightarrow \\ y_{i1}-y_{i2} &= \beta_1 (x_{i1} - x_{i2}) + c_i-c_i + u_{i1}-u_{i2} \\ \Delta y_{i} &= \beta_1 \Delta x_{i} + \Delta u_{i} \end{align} where $\Delta$ means *difference over time of* and to recover the parameter of interest $\beta_1$ we would run ```{r,eval=FALSE} lm(deltay ~ deltax, diff_data) ``` ### The Within Transformation In cases with $T>2$ we need a different approach - this is the most relevant case. One important concept is called the *within* transformation.^[Different packages implement different flavours of this procedure, this is the main gist] This is directly related to our discussion from above when we simplified our DAG. So, *controlling for group identity and only looking at time variation* is what we said - let's write it down! Here we denote as $\bar{x}_i$ the average *over time* of $i$'s $x$ values: $$ \bar{x}_i = \frac{1}{T} \sum_{t=1}^T x_{it} $$ With this in hand, the transformation goes like this: 1. for all variables compute their time-mean for each unit $i$: $\bar{x}_i,\bar{y}_i$ etc 1. for each observation, substract that time mean from the actual value and define $(x_{it} - \bar{x}_i),(y_{it}-\bar{y}_i)$ 1. Finally, regress $(x_{it} - \bar{x}_i)$ on $(y_{it}-\bar{y}_i)$ This *works* for our problem with fixed effect $c_i$ because $c_i$ is not time varying by assumption! hence it drops out: $$ y_{it}-\bar{y}_i = \beta_1 (x_{it} - \bar{x}_i) + c_i - c_i + u_{it}-\bar{u}_i $$ It's easy to do yourself! First let's compute the demeaned values: ```{r} cdata <- css %>% group_by(county) %>% mutate(mean_crime = mean(crmrte), mean_prob = mean(prbarr)) %>% mutate(demeaned_crime = crmrte - mean_crime, demeaned_prob = prbarr - mean_prob) ``` Then lets run the models with OLS: ```{r tab1} mod$xsect <- lm(crmrte ~ prbarr, data = cdata) mod$demeaned <- lm(demeaned_crime ~ demeaned_prob, data = cdata) gom = 'DF|Deviance|AIC|BIC|p.value|se_type|R2 Adj. |statistic|Log.Lik.|Num.Obs.' # stuff to omit from table modelsummary::modelsummary(mod[c("xsect","dummy","demeaned")], statistic = 'std.error', title = "Comparing (biased) X-secional OLS, dummy variable and manual demeaning panel regressions", coef_omit = "factor", gof_omit = gom) ``` Notice how in table \@ref(tab:tab1) the estimate for `prbarr` is positive in the cross-section, like in figure \@ref(fig:crime1). If we take care of the unobservered heterogeneity $c_i$ either by including an intercept for each $i$ or by time-demeaning the data, we obtain the same estimate: `r round(coef(mod$demeaned)[2],3)` in both cases. ```{r,echo = FALSE} panel_p = round(predict(mod$dummy,newdata = data.frame(prbarr = c(0.2,0.3), county = factor(1))),3) ``` We interpret those *within* estimates by imagining to look at a single unit $i$ and ask: *if the arrest probability in $i$ increases by 10 percentage points (i.e. from 0.2 to 0.3) from year $t$ to $t+1$, we expect crimes per person to fall from `r panel_p[1]` to `r panel_p[2]`, or by `r round(100 * diff(panel_p) / panel_p[1],2)` percent* (in the reference county number 1). ### Using a Package In real life you will hardly ever perform the within-transformation by yourself and use a package instead. There are several options (`fixest` if fastest). ```{r} mod$FE = fixest::feols(crmrte ~ prbarr | county, cdata) modelsummary::modelsummary(mod[c("xsect","dummy","demeaned","FE")], statistic = 'std.error', title = "Comparing (biased) X-secional OLS, dummy variable, manual demeaning and fixest panel regressions", coef_omit = "factor", gof_omit = paste(gom,"Std. errors","R2",sep = "|")) ``` Again, we get the same result as with manual demeaning 😅. Let's finish off with a nice visualisation by [Nick C Huntington-Klein's](http://nickchk.com) which illustrates how the within transformation works in this example. If you look back at $$ y_{it}-\bar{y}_i = \beta_1 (x_{it} - \bar{x}_i) + u_{it}-\bar{u}_i $$ you can see that we perform a form of **data centering** in the within transformation: subtracting their respective time means from all variables means to center all variables! Here's how this looks (only visible in HTML version online). ```{r anim, echo=FALSE, fig.cap = "Animation of a fixed effects panel data estimator: we remove *between group* variation and concentrate on *within group* variation only", fig.width=5, fig.height=4.5,message = FALSE, warning = FALSE, eval = knitr::is_html_output()} library(gganimate) cranim <- css %>% mutate(allcrm = mean(crmrte), allmpr = mean(prbarr)) %>% group_by(county) %>% mutate(label = case_when( crmrte == max(crmrte) ~ paste('County',county), TRUE ~ NA_character_ ), mcrm = mean(crmrte), mpr = mean(prbarr), stage = '1. Raw Data') cranim <- cranim %>% bind_rows(cranim %>% mutate(crmrte = crmrte - mcrm + allcrm, prbarr = prbarr - mpr + allmpr, mcrm = allcrm, mpr = allmpr, stage = '2. Remove all between variation')) p <- ggplot(cranim, aes(x = prbarr, y = crmrte, color = factor(county), label = label)) + geom_point() + geom_text(hjust = -.1, size = 14/.pt) + labs(x = 'Probability of Arrest', y = 'Crime Rate') + guides(color = FALSE, label = FALSE) + # scale_color_manual(values = c('black','blue','red','purple')) + geom_smooth(aes(color = NULL), method = 'lm', se = FALSE)+ theme_bw() + geom_point(aes(x = mpr, y = mcrm), size = 20, shape = 3, color = 'darkorange') + transition_states(stage) animate(p, nframes = 80) ``` ================================================ FILE: 13-discrete.Rmd ================================================ # Binary Outcomes {#binary} Until now we have encountered only contiunously distributed outcomes on the right hand side of our estimation equations. For example, in our typical linear model, we would define \begin{align} y &= b_0 + b_1 + e \\ e &\sim N\left(0,\sigma^2\right) \end{align} where the second line defines the unobservable $e$ to be drawn from the Normal distribution with mean zero and variance $\sigma^2$.^[We have not insisted too much on the fact that $e$ should be distributed according to the *Normal* distribution (this is required in particular for the theoretical derivation of standard errors as seen in chapter \@ref(std-errors)). However, we'd always have an unbounded and continuous distribution underlying our models] That means that, at least in principle, $y$ could be any number from the real line ($e$ could be arbitrarily small or large), and we can say that $y \in \mathbb{R}$. For the outcomes we studied, that was fine: test scores, earnings, crime rates etc are all continuous outcomes. But some outcomes are clearly binary (i.e. either `TRUE` or `FALSE`): * You either work or you don't, * You either have children or you don't, * You either bought a product or you didn't, * You flipped a coin and it came up either heads or tails. In this situation, our outcome is restricted to come from a small set of values: `FALSE` vs `TRUE`, or `0` vs `1`. We'd have $y \in \{0,1\}$. In those situations we are primarily interested in estimating the **response probability** or the **probability of success**, $$ p(x) = \Pr(y=1 | x), $$ or in words, *the probability to observe $y=1$ (a success), given explanatory variables $x$*. In particular, we will often be interested in learning how $p(x)$ changes as we change $x$ - that is, we are interested in the same *partial effect* of $x$ on the outcome as in our usual linear regression setup. Here, we ask ```{block,type = "tip"} If we increase $x$ by one unit, how would the probability of $y=1$ change? ``` It is worth reminding ourselves about two simple facts about binary random variables (i.e drawn from the [Bernoulli](https://en.wikipedia.org/wiki/Bernoulli_distribution) distribution). So, we call a random variable $y \in \{0,1\}$ such that \begin{align} \Pr(y = 1) &= p \\ \Pr(y = 0) &= 1-p \\ p &\in[0,1] \end{align} a *Bernoulli* random variable. In our setting, we just *condition* those probabilities on a covariate $x$, as above - that is, we measure the probability *given that $X$ takes value $x$*: \begin{align} \Pr(y = 1 | X = x) &= p(x) \\ \Pr(y = 0 | X = x) &= 1-p(x) \\ p(x) &\in[0,1] \end{align} Of particular interest for us is the fact that the *expected value* (i.e. the average) of $Y$ given $x$ is $$ E[y | x] = p(x) \times 1 + (1-p(x)) \times 0 = p(x) $$ There are several ways to model such binary outcomes. Let's look at them. ## The Linear Probability Model The Linear Probability Model (LPM) is the simplest option. In this case, we model the response probability as $$ \Pr(y = 1 | x) = p(x) = \beta_0 + \beta_1 x_1 + \dots + \beta_K x_K (\#eq:LPM) $$ Our interpretation is slightly changed to our usual setup, as we'd say *a 1 unit change in $x_1$, say, results in a change of $p(x)$ of $\beta_1$.* Estimation of the LPM as in equation \@ref(eq:LPM) can be performed by standard OLS. Let's look at an example. The Mroz (1987) dataset let's us investigate female labor market participation. How does a woman's `inlf` (*in labor force*) status depend on non-wife household income, her education, age and number of small children? First, let's look at a quick plot that shows how the outcome varies with 1 variable, age say: ```{r} data(mroz, package = "wooldridge") plot(factor(inlf) ~ age, data = mroz, ylevels = 2:1, ylab = "in labor force?") ``` Not so much variation with respect to age, except for the later years. Let's run the LPM now: ```{r} LPM = lm(inlf ~ nwifeinc + educ + exper + I(exper^2) + age +I(age^2) + kidslt6, mroz) summary(LPM) ``` You can see that this is *identical* to our previous linear regression models - with the exception that the outcome `inlf` takes on only two values, 0 or 1. The results from this: if non-wife income increases by 10 (i.e 10,000 USD), the probability of being in the labor force falls by 0.034 (that's a small effect!), whereas an additional small child would reduce the probability of work by 0.26 (that's large). So far, so simple. One often-mentioned problem of this model is that fact that nothing restricts our predictions of $p(x)$ to be proper probabilities, i.e. to lie in the unit interval $[0,1]$. You can see that quite easily here: ```{r} pr = predict(LPM) plot(pr[order(pr)],ylab = "p(inlf = 1)") abline(a = 0, b = 0, col = "red") abline(a = 1, b = 0, col = "red") ``` This picture tells you that for quite a few observations, this model predicts a probability of working which is either greater than 1, or smaller than zero. This may or may not be a big problem for your analysis. If you only care about marginal effects (i.e. the $\beta$s, that may be ok, in particular if you have discrete variables on the RHS; if you want actual *predictions* than that's more problematic). In the case of a *saturated model* - if we only have dummy explanatory variables - then this problem does not exist for the LPM: ```{r saturated,message=FALSE,warning=FALSE,fig.cap = "LPM model in a saturated setting, i.e. only mutually exhaustive dummy variables on the RHS."} library(dplyr) library(ggplot2) mroz %<>% # classify age into 3 and huswage into 2 classes mutate(age_fct = cut(age,breaks = 3,labels = FALSE), huswage_fct = cut(huswage, breaks = 2,labels = FALSE)) %>% mutate(classes = paste0("age_",age_fct,"_hus_",huswage_fct)) LPM_saturated = mroz %>% lm(inlf ~ age_fct + huswage_fct, data = .) mroz$pred <- predict(LPM_saturated) ggplot(mroz[order(mroz$pred),], aes(x = 1:nrow(mroz),y = pred,color = classes)) + geom_point() + theme_bw() + scale_y_continuous(limits = c(0,1), name = "p(inlf)") + ggtitle("LPM in a Saturated Model is Perfectly Fine") ``` In figure \@ref(fig:saturated) each line segment corresponds to the average probability of work *within that cell* of people. For example you see that women from the youngest age category and lowest husband income (class `age_1_hus_1`) have the highest probability of working (`r round(max(mroz$pred),3)`). ## Nonlinear Binary Response Models In this class of models we change the way we model the response probability $p(x)$. Instead of the simple linear structure from above, we write $$ \Pr(y = 1 | x) = p(x) = G \left(\beta_0 + \beta_1 x_1 + \dots + \beta_K x_K \right) (\#eq:GLM) $$ You note that this is *almost* identical, only that the entire sum $\beta_0 + \beta_1 x_1 + \dots + \beta_K x_K$ is now inside some function $G(\cdot)$. The main property of $G$ is that it can transform any value $z\in \mathbb{R}$ you give it to a number in the interval $(0,1)$. This immediately solves our problem of getting weird predictions for probabilities. The two most widely used forms of $G$ are the **probit** and the **logit** model. here are both forms for $G$ in one plot: ```{r cdfs, fig.cap = "The Probit and Logit functional forms for binary choice models",warning = FALSE} library(ggplot2) ggplot(data.frame(x = c(-5,5)), aes(x=x)) + stat_function(fun = pnorm, aes(colour = "Probit")) + stat_function(fun = plogis, aes(colour = "Logit")) + theme_bw() + scale_colour_manual(name = "Function G",values = c("red", "blue")) + scale_y_continuous(name = "Pr(y = 1 | x)") ``` You can see that 1. any value $x$ results in a value $y$ between 0 and 1 1. the higher $x$, the higher the resulting $p(x)$. ### Interpretation of Coefficients Let's run the Mroz example from above in both probit and logit now: ```{r} probit <- glm(inlf ~ age, data = mroz, family = binomial(link = "probit")) logit <- glm(inlf ~ age, data = mroz, family = binomial(link = "logit")) modelsummary::modelsummary(list("probit" = probit,"logit" = logit)) ``` From this table, we learn that the coefficient for `age` is `r round(coef(probit)[2],3)` for probit and `r round(coef(logit)[2],3)` for logit, respectively. In both cases, this tells us that the impact of an additional year of age on the probability of working is **negative**. However, we cannot straightforwardly read off the *magnitude* of the effect - **how much** does the probability decrease we can't tell. Why is that? One simple way to see this is to look back at figure \@ref(fig:cdfs) and imagine we had just one explanatory variable (like here - `age`). The model is $$ \Pr(y = 1 | \text{age})= G \left(x \beta\right) = G \left(\beta_0 + \beta_1 \text{age} \right) $$ and the *marginal effect* of `age` on the response probability is $$ \frac{\partial{\Pr(y = 1 | \text{age})}}{ \partial{\text{age}}} = g \left(\beta_0 + \beta_1 \text{age} \right) \beta_1 (\#eq:ME) $$ where function $g$ is defined as $g(z) = \frac{dG}{dz}(z)$ - the first derivative function of $G$ (i.e. the *slope* of $G$). The formulation in \@ref(eq:ME) is a result of the [chain rule](https://en.wikipedia.org/wiki/Chain_rule). Now, given that in figure \@ref(fig:cdfs) we see $G$ that is nonlinear, this means that also $g$ will be non-linear: sometimes (close to the edges of the graph) the slope will be really small and close to zero, but sometimes (in the center of the graph), the slope will be really steep. You are able to try this out yourself using this app: ```{r, eval = FALSE} ScPoApps::launchApp("marginal_effects_of_logit_probit") ``` So you can see that there is not one single *marginal effect* in those models, as that depends on *where we evaluate* expression \@ref(eq:ME). Notice that the case is identical for more than one $x$. In practice, there are two common approaches: 1. report \@ref(eq:ME) at the average values of $x$: $$g(\bar{x} \beta) \beta_j$$ 1. report the sample average of all marginal effects: $$\frac{1}{n} \sum_{i=1}^N g(x_i \beta) \beta_j$$ Thankfully there are packages available that help us to compute those marginal effects fairly easily. One of them is called [`mfx`](https://cran.r-project.org/web/packages/mfx/), and we would use it as follows: ```{r glms} f <- "inlf ~ age + kidslt6 + nwifeinc" # setup a formula glms <- list() glms$probit <- glm(formula = f, data = mroz, family = binomial(link = "probit")) glms$logit <- glm(formula = f, data = mroz, family = binomial(link = "logit")) # now the marginal effects versions glms$probitMean <- mfx::probitmfx(formula = f, data = mroz, atmean = TRUE) glms$probitAvg <- mfx::probitmfx(formula = f, data = mroz, atmean = FALSE) glms$logitMean <- mfx::logitmfx(formula = f, data = mroz, atmean = TRUE) glms$logitAvg <- mfx::logitmfx(formula = f, data = mroz, atmean = FALSE) modelsummary::modelsummary(glms, stars = TRUE, gof_omit = "AIC|BIC", title = "Logit and Probit estimates and marginal effects evaluated at mean of x or as sample average of effects") ``` In table \@ref(tab:glms) you should first note that the estimates of the first two columns (probit or logit) don't correspond to the remaining columns. That's because they only give you the $\beta$'s. As we have learned above, that in itself is not informative, as it depends *where* one computes the marginal effects. Hence the remaining columns compute the marginal effects either at the mean of all regressors (`probitMean`) or as the sample average over all effects in the data (`probitAvg`). You can notice some differences here, for example we find at the average regressor, an additional child below age of 6 reduces the probability of work by 0.314, whereas as an averag over all sample effects it reduces it by 0.29. Furthermore, you see that the marginal effect estimates between probit and logit don't correspond exactly, which is a consequence of the different shapes of the curves in figure \@ref(fig:cdfs). No one approach is correct here and depends on how your data is distributed (e.g. is the mean a good summary of the data here?). What is clear, though, is that in most cases reporting coefficient estimates only is not very informative (it only tells you the direction of any effect). ================================================ FILE: 14-references.Rmd ================================================ `r if (knitr::is_html_output()) '# References {-}'` ================================================ FILE: DESCRIPTION ================================================ Package: ScPoEconometrics Type: Package Title: ScPoEconometrics Date: 2020-10-31 Version: 0.2.7 Authors@R: c( person("Florian", "Oswald", email = "florian.oswald@sciencespo.fr", role = c("aut","cre")), person("Jean-Marc", "Robin", email = "jeanmarc.robin@sciencespo.fr", role = "ctb"), person("Vincent", "Viers", email = "vincent.viers@sciencespo.fr", role = "ctb"), person("Gustave", "Kenedi", email = "gustave.kenedi@sciencespo.fr", role = "ctb"), person("Pierre", "Villedieu", email = "pierre.villedieu@sciencespo.fr", role = "ctb")) Depends: R (>= 3.5.0) License: MIT + file LICENSE Description: The is the 2nd year UG econometrics book at SciencesPo. URL: https://github.com/ScPoEcon/ScPoEconometrics Imports: bookdown, tidyverse, datasauRus, plotly, webshot, Ecdat, rmarkdown (>= 1.11), AER, magick, pdftools, Hmisc, magrittr, dplyr, corrplot, cowplot, wooldridge, stargazer, quantreg, equatiomatic, ungeviz, masteringmetrics, ggdag, data.table, huxtable, cholera, reshape2, modelsummary, estimatr, gganimate, fixest, transformr, mfx Remotes: datalorax/equatiomatic, wilkelab/ungeviz, jrnold/masteringmetrics/masteringmetrics RoxygenNote: 7.1.1 ================================================ FILE: GA-tracker.html ================================================ ================================================ FILE: LICENSE ================================================ This work is licensed under the Creative Commons Attribution-NonCommercial-ShareAlike 4.0 International License. To view a copy of this license, visit http://creativecommons.org/licenses/by-nc-sa/4.0/ or send a letter to Creative Commons, PO Box 1866, Mountain View, CA 94042, USA. ================================================ FILE: NAMESPACE ================================================ # Generated by roxygen2: do not edit by hand ================================================ FILE: R/utils.R ================================================ gitbook <- function(){ bookdown::render_book('index.Rmd', 'bookdown::gitbook') } pdfbook <- function(){ bookdown::render_book('index.Rmd', 'bookdown::pdf_book') } pasta_maker <- function(){ pasta_jar <- tibble::tibble(id = 1:1980,color = sample(c(rep("Red",488),rep("Green",492),rep("White",1000)), size = 1980 )) usethis::use_data(pasta_jar,overwrite = TRUE) pasta_jar } pasta_image <- function(){ data(pasta_jar) pasta_jar$cf = as.numeric(factor(pasta_jar$color)) m = matrix(c(pasta_jar$cf),44,45) image(m,col = c("green","orange","white"),xaxt="n",yaxt = "n") } ================================================ FILE: README.md ================================================ # ScPo UG Econometrics This is the git repo for the UG Econometrics book taught to 2nd year students at SciencesPo. **Slides for the Intro Course?** If you are looking for the introductory course slides, they are in the [ScPoEconometrics-Slides](https://github.com/ScPoEcon/ScPoEconometrics-Slides) repo. **Slides for the Advanced Course?** If you are looking for the advanced course slides, they are in the [Advanced-Metrics-Slides](https://github.com/ScPoEcon/Advanced-Metrics-slides) repo. **Apps and Tutorials?** If you are looking for our apps and tutorials, they are in the [ScPoApps](https://github.com/ScPoEcon/ScPoApps) repo. ## Meta Information for Teachers *This section is only relevant if you want to teach this course.* All material of this course is open source, and you are free to use it. Please refer to the [license](#license) section below for the precise wording and terms of the agreement. In particular, please stick to the agreement about proper citation of this repository. There is some relevant material in the [teachers](/teachers) folder. In particular, the `ForTeachers.md` document contains a detailed explanation of the course structure, as well as a section on student feedback from the first iteration of the course. The few other documents in there should be self explanatory. As outlined in the license section, you are free to use and re-use any parts of the content as you see fit. For instance, you could re-use our slides, and modify them, or publish a different version of our textbook (with proper attribution). However, it could be valuable to integrate your changes/additions to the project. In this case, please read on in the next section about how to make contributions. ## Contribution Workflow - Developers only! This section is only for people who want to contribute code to this project. 1. fork this repository 1. clone your fork to your computer: `git clone url_of_your_fork` 1. Start to work on your things on a new branch: `git checkout -b new_branch` 1. **commit** your work to that new branch! 1. Place your new stuff on top of the most recent `upstream/master`: 1. add the upstream repo as a remote: `git remote add upstream git@github.com:ScPoEcon/ScPoEconometrics.git` 1. Use the `rebase` command ``` # git add your stuff # git commit your stuff git fetch upstream # get stuff from upstream git rebase upstream/master # merge upstream master and put your commits on top of it ``` 1. push that branch to your fork: `git push origin new_branch` 1. create pull request on `upstream` (from your fork at github.com) ## Technology The book is made using bookdown. You can find the preview of an example at https://bookdown.org/yihui/bookdown-demo/ ## License This work is licensed under a [Creative Commons Attribution-NonCommercial-ShareAlike 4.0 International License](http://creativecommons.org/licenses/by-nc-sa/4.0/)  You are free to: * Share — copy and redistribute the material in any medium or format * Adapt — remix, transform, and build upon the material **under the following terms**: 1. Attribution — You must give appropriate credit, provide a link to the license, and indicate if changes were made. You may do so in any reasonable manner, but not in any way that suggests the licensor endorses you or your use. We are happy to suggest the following citation if you use our material in your work: ```R > citation("ScPoEconometrics") Oswald F, Viers V, Villedieu P, Kennedy G (2020). Introduction to Econometrics with R. SciencesPo Department of Economics, Paris, France.
Our task is now to decide if given that particular sampling distribution, given our estimate $\bar{x}$ and given an observed sample variance $s^2$, whether $\bar{x} = `r xbar`$ is *far away* from $\bar{x} = `r mu`$, or not. The way to proceed is by computing a *test statistic*, which is to be compared to a *critical value*: if the test statistic exceeds that value, we reject $H_0$, otherwise we cannot. The critical value depends on the sampling distribution, and the size of the test. We talk about this next. ### Making Errors There are two types of error one can make when deploying such a test: 1. We might reject $H_0$, when in fact it is true! Here, upon observing $\bar{x} = `r xbar`$ we might conclude that indeed $\mu > `r mu`$ and thus we'd reject. But we might have gotten unlucky and by chance have obtained an unusually tall sample of students. This is called **type one error**. 2. We might *fail* to reject $H_0$ when in fact $H_1$ is true. This is called the **type two error**. We design a test with a certain probability of *type one error* $\alpha$ in mind. In other words, we choose with which probability $\alpha$ we are willing to make a type one error. (Notice that the best tests also avoid making type two errors! The number $1-\Pr(\text{type 2 error})$ is called *power*, hence we prefer tests with *high power*). A typical choice for $\alpha$ is 0.05, i.e. we are willing to make a type one error with probability 5%. $\alpha$ is commonly called the **level of significance** or the **size** of a test. ### Performing the Test We can stick to the following cookbook procedure, which is illustrated in figure \@ref(fig:testfig). 1. Set up hypothesis and significance level: 1. $H_0: \mu = `r mu`$ 2. $H_1: \mu > `r mu`$ 3. $\alpha = 0.05$ 2. Test Statistic and test distribution: * We don't know the true population variance $\sigma^2$, hence we estimate it via $s^2$ from our sample. * The corresponding test statistic is the *t-statistic*, which follows the [Student's T](https://en.wikipedia.org/wiki/Student's_t-distribution) distribution. * That is, our statistic is $T=\frac{\bar{x} - \mu}{s/\sqrt{n}} \sim t_{`r n-1`}$, where `r n-1` is equal to the *degrees of freedom* in this case. 3. Rejection Region: We perform a one-sided test. We said we are happy with a 5% significance level, i.e. we are looking for the $t$ value which corresponds *just* to $1-0.05 = 0.95$ mass under the pdf of the $t$ distribution. More precisely, we are looking for the $1-0.05 = 0.95$ quantile of the $t_{`r n`}$ distribution.^[See the previous footnote for an explanation of this!] This implies a critical value $c = `r round(qt(0.95,df=n),3)`$, which you can verify by typing `qt(0.95,df=50)` in `R`. 4. Calculate our test statistic: $\frac{\bar{x} - \mu}{s/\sqrt{n}} = \frac{168.5 - 167}{`r s`/\sqrt{`r n`}} = `r tstat`$ 5. Decide: We find that $`r tstat` < `r round(ctval,3)`$. Hence, we cannot reject $H_0$, because we only found weak evidence against it in our sample of data. ```{r testfig, echo=FALSE, engine='tikz', out.width='90%', fig.ext=if (knitr:::is_latex_output()) 'pdf' else 'png', fig.cap='Cookbook Testing Proceedure. Subscripts $c$ indicate *critical value*. There are two x-axis: one for values of $\\bar{x}$, and one for the corresponding $t$ statistic. The red area is the rejection area. If we observe a test statistic such that $t>t_c$, we feel reassured that our $\\bar{x}$ is *sufficiently far away* from the hypothesized value $\\mu$, such that we feel comfortable with rejecting $H_0$. And vice versa: If our test statistic falls below $t_c$, we will not reject $H_0$',fig.align='center'} \begin{tikzpicture}[scale=2, y=5cm] \draw[domain=-3:1.645] plot[id=gauss1, samples=100] (\x,{1/sqrt(2*pi)*exp(-0.5*(\x)^2)}); \draw[domain=1.645:3.2,fill=red,opacity=0.4] (1.645,0) -- plot[id=gauss3, samples=25] (\x,{1/sqrt(2*pi)*exp(-0.5*(\x)^2)}); \draw (1.645,-0.01) -- (1.645,0.01); % tick \node at (1.645,-0.03) {$\bar{x}_c = 171.74$}; \draw[->, semithick] (-3.2,0) -- (3.4,0) node[right] {$\bar{x}$}; % x-axis 1 \draw[->, semithick] (-3.2,-0.1) -- (3.4,-0.1) node[right] {$t=\sqrt{n} \frac{\bar{x}-\mu}{s}$}; % x-axis 2 %y-axis \draw[->, semithick] (-3.15,-0.02) node[left] {$0$} -- (-3.15,0.45) node[above] {$f(\bar{x}|\mu=167)$}; % y-axis \draw[-,semithick] (0,-0.01) -- (0,0.01); % zero tick on x \draw[-,semithick] (0,-0.11) -- (0,0.-0.09); % zero tick on z \node at (0,-0.03) {$\mu = 167$}; \node at (0,-0.13) {$0$}; \draw[-,semithick] (1.645,-0.11) -- (1.645,-0.09); \node at (1.645,-0.13) {$t_c = 1.676$}; % annotate alphas \node at (0,0.15) {$1 - \alpha = 0.95$}; \draw (2,0.02) -- (2.4,0.1) node[above] {$\alpha = 0.05$}; \end{tikzpicture} ``` You can see from this that whether or not our test statistic is far way from the critical value, or just below does not change our decision: it's either accept or reject. We never know if we *narrowly* rejected a $H_0$, or not. P-values are an improvement over this stark dichotomy. The p-value is defined as the particular level of significance $\alpha^*$, up to which *all* $H_0$'s would be rejected. If this is a very small number, we have overwhelming support to reject the null. If, on the contrary, $\alpha^*$ turns out to be rather large, we only found weak evidence against $H_0$. We define the p-value as the sum of rejection areas for a given test statistic $T^*$. Notice that the symmetry of the $t$ distribution implies that we would multiply by two each of the two tail probabilities in the case of a two-sided test. \begin{align} \alpha^* = \Pr(t > |T^*|) \end{align} ### Standard Errors in Practice We would like to further make this point in an experiential way, i.e. we want you to experience what is going on. We invite you to spend some time with the following apps. In particular, make sure you have a thorough understanding of `launchApp("estimate")`. ```{r,eval=FALSE} library(ScPoApps) launchApp("estimate") launchApp("sampling") launchApp("standard_errors_simple") launchApp("standard_errors_changeN") ``` ### Testing Regression Coefficients In Regression Analysis, we often want to test a very specific alternative hypothesis: We want to have a quick way to tell us whether a certain variable $x_k$ is *relevant* in our statistical model or not. In hypothesis testing language, that would be \begin{align} H_0:& \beta_k = 0\\ H_1:& \beta_k \neq 0.(\#eq:H0) \end{align} Clearly, if in the **true** regression model we find $\beta_k=0$, this means that $x_k$ has a zero partial effect on the outcome, hence it should be excluded from the regression. Notice that we are interested in $\beta_k$, not in $b_k$, which is the estimator that we compute from our sample (similarly to $\bar{x}$, which estimates $\mu$ above). As such, this is a *two-sided test*. We can again illustrate this in figure \@ref(fig:testfig2). Notice how we now have two rejection areas. ```{r testfig2, echo=FALSE, engine='tikz', out.width='90%', fig.ext=if (knitr:::is_latex_output()) 'pdf' else 'png', fig.cap='Testing whether coefficient $b_k$ is *statistically significantly different* from zero. Now we have two red rejection areas. We relabel critical values with a superscript here. If we observe a test statistic falling in either red region, we reject, else we do not. Notice that the true value under $H_0$ is $\\beta_k=0$. ',fig.align='center'} \begin{tikzpicture}[scale=2, y=5cm] \draw[domain=-3.15:-1.96,fill=red,opacity=0.4] (-3.15,0) plot[id=gauss1,samples=50] (\x,{1/sqrt(2*pi)*exp(-0.5*(\x)^2)}) -- (-1.96,0); \draw[domain=-1.96:1.96] plot[id=gauss1, samples=100] (\x,{1/sqrt(2*pi)*exp(-0.5*(\x)^2)}); \draw[domain=1.96:3.2,fill=red,opacity=0.4] (1.96,0) -- plot[id=gauss3, samples=50] (\x,{1/sqrt(2*pi)*exp(-0.5*(\x)^2)}); \draw (1.96,-0.01) -- (1.96,0.01); % ticks \draw (-1.96,-0.01) -- (-1.96,0.01); % ciritcal estimator values \node at (1.96,-0.03) {$b_k^c$}; \node at (-1.96,-0.03) {$-b_k^c$}; % ticks on t \draw[-,semithick] (1.96,-0.11) -- (1.96,-0.09); \node at (1.96,-0.13) {$t_{up}=1.96$}; \draw[-,semithick] (-1.96,-0.11) -- (-1.96,-0.09); \node at (-1.96,-0.13) {$t_{down}=-1.96$}; % x-axis 1 \draw[->, semithick] (-3.2,0) -- (3.4,0) node[right] {$b_k$}; \draw[->, semithick] (-3.2,-0.1) -- (3.4,-0.1) node[right] {$t=\frac{b_k-0}{s_k}$}; % x-axis 2 %y-axis \draw[->, semithick] (-3.15,-0.02) node[left] {$0$} -- (-3.15,0.45) node[above] {$f(b_k|\beta_k=0)$}; \draw[-,semithick] (0,-0.01) -- (0,0.01); % zero tick on x \draw[-,semithick] (0,-0.11) -- (0,0.-0.09); % zero tick on t \node at (0,-0.03) {$\beta_k = 0$}; \node at (0,-0.13) {$0$}; % annotate alphas \node at (0,0.15) {$1 - \alpha = 0.95$}; \draw (2.2,0.02) -- (2.4,0.1) node[above] {$\frac{\alpha}{2} = 0.025$}; \draw (-2.2,0.02) -- (-2.4,0.1) node[above] {$\frac{\alpha}{2} = 0.025$}; \end{tikzpicture} ``` The relevant test statistic for a regression coefficient is again the *t* distribution. In fact, this particular test is so important that all statistical packages report the *t* statistic corresponding to \@ref(eq:H0) automatically. Let's look at an example: ```{r,echo=FALSE} lm1=lm(mpg ~ wt + hp + drat, mtcars) summary(lm1) ``` The column `t value` is just `Estimate` divided by `Std. Error`. That is, `R` reports in the column `t value` the following number for us: \begin{equation} \text{t value} = \frac{b_k-0}{s_k} (\#eq:tstat) \end{equation} where $s_k$ is the estimated standard error as introduced in \@ref(se-theory), and where we test $H_0:\beta_k = 0$. Notice that this particular *t* statistic is different from our previous formulation in \@ref(eq:tscore): we don't have to scale by $\sqrt{n}$! This is so because `R` and other statistical software assumes the *normal* linear regression model (see \@ref(class-reg)). Normality of the regression error $\varepsilon$ implies that the *t* statistic looks like in \@ref(eq:tstat). We have to choose a critical value for this test. Many people automatically choose the 0.975 quantile of the standard normal distribution, `qnorm(0.975)`, `r round(qnorm(0.975),2)` in this case. This is fine for sample sizes greater than 100, say. In this regression, we only have 28 degrees of freedom, so we better choose the critical value from the *t* distribution as above. We get $t_{down} = `r round(qt(0.025,df=28),3)`$ and $t_{up} = `r round(qt(0.975,df=28),3)`$ as critical values. Let's test whether the coefficient on `wt` is statistically different from zero: \begin{align} H_0:& \beta_{wt} = 0\\ H_1:& \beta_{wt} \neq 0 (\#eq:mtcarswt) \end{align} We just take the `t value` entry, and see whether it lies above or below either critical value: Indeed, we see that $-4.053 < `r round(qt(0.025,df=28),3)`$, and we are happy to reject $H_0$. On the other hand, when testing for statistical significance of `drat` that does not seem to be the case: \begin{align} H_0:& \beta_{drat} = 0\\ H_1:& \beta_{drat} \neq 0 (\#eq:mtcarsdrat) \end{align} Here we find that $1.316 \in [`r round(qt(0.025,df=28),3)`,`r round(qt(0.975,df=28),3)`]$, hence it does not lie in any rejection region, and we can *not* reject $H_0$. We would say that *coefficient $\beta_{drat}$ is not statistically significant at the 5% level*. As such, we should not include it in our regression. ### P-Values and Stars `R` also reports two additional columns in its regression output. The so-called *p-value* in column `Pr(>|t|)` and a column with stars. P-values are an improvement over the dichotomy introduced in the standard reject/accept framework above. We never know if we *narrowly* rejected a $H_0$, or not. The p-value is defined as the particular level of significance $\alpha^*$, up to which *all* $H_0$'s would be rejected. If this is a very small number, we have overwhelming support to reject the null. If, on the contrary, $\alpha^*$ turns out to be rather large, we only found weak evidence against $H_0$. We define the p-value as the sum of rejection areas for a given test statistic $T^*$. Notice that the symmetry of the $t$ distribution implies that we multiply by two each of the two tail probabilities: \begin{align} \alpha^* = 2 \Pr(t > |T^*|) \end{align} The stars in the final column are a visualization of this information. They show a quick summary of the magnitude of each p-value. Commonly, `***` means an extremely small reference significance level $\alpha^*=0$ (almost zero), `**` means $\alpha^*=0.001$, etc. In that case, up to a significance level of 0.1%, all $H_0$ would be rejected. You clearly see that all columns `Std. Error`, `t value` and `Pr(>|t|)` give a different type of the same information. * Measurement error * Omitted Variable Bias * Reverse Causality / Simultaneity Bias are all called *endogeneity* problems. ## Simultaneity Bias * Detroit has a large police force * Detroit has a high crime rate * Omaha has a small police force * Omana has a small crime rate Do large police forces **cause** high crime rates? Absurd! Absurd? How could we use data to tell? We have the problem that large police forces and high crime rates covary positively in the data, and for obvious reasons: Cities want to protect their citizens and therefore respond to increased crime with increased police. Using mathematical symbols, we have the following *system of linear equations*, i.e. two equations which are **jointly determined**: \begin{align*} \text{crime}_{it} &= f(\text{police}_{it}) \\ \text{police}_{it}&= g(\text{crime}_{it} ) \end{align*} We need a factor that is outside this circular system, affecting **only** the size of the police force, but not the actual crime rate. Such a factor is called an *instrumental variable*. ================================================ FILE: _to_be_done/09-R-advanced.Rmd ================================================ # Advanced `R` {#R-advanced} This chapter continues with some advanced usage examples from chapter \@ref(R-intro) ## More Vectorization ```{r} x = c(1, 3, 5, 7, 8, 9) y = 1:100 ``` ```{r} x + 2 x + rep(2, 6) ``` ```{r} x > 3 x > rep(3, 6) ``` ```{r} x + y length(x) length(y) length(y) / length(x) (x + y) - y ``` ```{r} y = 1:60 x + y length(y) / length(x) ``` ```{r} rep(x, 10) + y ``` ```{r} all(x + y == rep(x, 10) + y) identical(x + y, rep(x, 10) + y) ``` ```{r} # ?any # ?all.equal ``` ## Calculations with Vectors and Matrices Certain operations in `R`, for example `%*%` have different behavior on vectors and matrices. To illustrate this, we will first create two vectors. ```{r} a_vec = c(1, 2, 3) b_vec = c(2, 2, 2) ``` Note that these are indeed vectors. They are not matrices. ```{r} c(is.vector(a_vec), is.vector(b_vec)) c(is.matrix(a_vec), is.matrix(b_vec)) ``` When this is the case, the `%*%` operator is used to calculate the **dot product**, also know as the **inner product** of the two vectors. The dot product of vectors $\boldsymbol{a} = \lbrack a_1, a_2, \cdots a_n \rbrack$ and $\boldsymbol{b} = \lbrack b_1, b_2, \cdots b_n \rbrack$ is defined to be \[ \boldsymbol{a} \cdot \boldsymbol{b} = \sum_{i = 1}^{n} a_i b_i = a_1 b_1 + a_2 b_2 + \cdots a_n b_n. \] ```{r} a_vec %*% b_vec # inner product a_vec %o% b_vec # outer product ``` The `%o%` operator is used to calculate the **outer product** of the two vectors. When vectors are coerced to become matrices, they are column vectors. So a vector of length $n$ becomes an $n \times 1$ matrix after coercion. ```{r} as.matrix(a_vec) ``` If we use the `%*%` operator on matrices, `%*%` again performs the expected matrix multiplication. So you might expect the following to produce an error, because the dimensions are incorrect. ```{r} as.matrix(a_vec) %*% b_vec ``` At face value this is a $3 \times 1$ matrix, multiplied by a $3 \times 1$ matrix. However, when `b_vec` is automatically coerced to be a matrix, `R` decided to make it a "row vector", a $1 \times 3$ matrix, so that the multiplication has conformable dimensions. If we had coerced both, then `R` would produce an error. ```{r, eval = FALSE} as.matrix(a_vec) %*% as.matrix(b_vec) ``` Another way to calculate a *dot product* is with the `crossprod()` function. Given two vectors, the `crossprod()` function calculates their dot product. The function has a rather misleading name. ```{r} crossprod(a_vec, b_vec) # inner product tcrossprod(a_vec, b_vec) # outer product ``` These functions could be very useful later. When used with matrices $X$ and $Y$ as arguments, it calculates \[ X^\top Y. \] When dealing with linear models, the calculation \[ X^\top X \] is used repeatedly. ```{r} C_mat = matrix(c(1, 2, 3, 4, 5, 6), 2, 3) D_mat = matrix(c(2, 2, 2, 2, 2, 2), 2, 3) ``` This is useful both as a shortcut for a frequent calculation and as a more efficient implementation than using `t()` and `%*%`. ```{r} crossprod(C_mat, D_mat) t(C_mat) %*% D_mat all.equal(crossprod(C_mat, D_mat), t(C_mat) %*% D_mat) ``` ```{r} crossprod(C_mat, C_mat) t(C_mat) %*% C_mat all.equal(crossprod(C_mat, C_mat), t(C_mat) %*% C_mat) ``` ## Matrices ```{r} Z = matrix(c(9, 2, -3, 2, 4, -2, -3, -2, 16), 3, byrow = TRUE) Z solve(Z) ``` To verify that `solve(Z)` returns the inverse, we multiply it by `Z`. We would expect this to return the identity matrix, however we see that this is not the case due to some computational issues. However, `R` also has the `all.equal()` function which checks for equality, with some small tolerance which accounts for some computational issues. The `identical()` function is used to check for exact equality. ```{r} solve(Z) %*% Z diag(3) all.equal(solve(Z) %*% Z, diag(3)) ``` `R` has a number of matrix specific functions for obtaining dimension and summary information. ```{r} X = matrix(1:6, 2, 3) X dim(X) rowSums(X) colSums(X) rowMeans(X) colMeans(X) ``` The `diag()` function can be used in a number of ways. We can extract the diagonal of a matrix. ```{r} diag(Z) ``` Or create a matrix with specified elements on the diagonal. (And `0` on the off-diagonals.) ```{r} diag(1:5) ``` Or, lastly, create a square matrix of a certain dimension with `1` for every element of the diagonal and `0` for the off-diagonals. ```{r} diag(5) ``` ================================================ FILE: _to_be_done/11-projects.Rmd ================================================ # Projects This chapter contains several empirical projects. ## Trade Exercise * [Trade exercise](images/trade.html) ================================================ FILE: _to_be_done/notes.R ================================================ data("STAR",package = "AER") x = as.data.table(STAR) mx = melt.data.table(x, id = 1:3, measure.vars = patterns("star*"), variable.name = "grade", value.name = "classtype") # mx[, grade := as.character(grade)] ms = melt.data.table(x, id = 1:3, measure.vars = patterns("read*","math*", "schoolid*", "degree*","experience*","tethnicity*"), variable.name = "grade", value.name = c("read","math","schoolid","degree","experience","tethniticy")) mx = cbind(mx,ms[,-c(1:4)]) mx = mx[complete.cases(mx)] setkey(mx, classtype) ecdfs = mx[classtype != "small", list(readcdf = list(ecdf(read)),mathcdf = list(ecdf(math))),by = grade] om = par("mar") par(mfcol=c(4,2),mar = c(2,om[2],2.5,om[4])) ecdfs[,.SD[,plot(mathcdf[[1]],main = paste("math ecdf grade",.BY))],by = grade] ecdfs[,.SD[,plot(readcdf[[1]],main = paste("read ecdf grade",.BY))],by = grade] par(mfcol=c(1,1),mar = om) setkey(ecdfs, grade) setkey(mx,grade) z=mx[,list(perc_read = ecdfs[(.BY),readcdf][[1]](read),perc_math = ecdfs[(.BY),mathcdf][[1]](math)),by=grade] z[,score := rowMeans(.SD), .SDcols = c("perc_read","perc_math")] mx = cbind(mx,z[,!"grade"]) ggplot(data = z, mapping = aes(x = score,color=classtype)) + geom_density() + facet_wrap(~grade) summary(lm(score ~ classtype + schoolid,mx[grade == "stark"])) ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_edges_diagonal() + geom_dag_text() + theme_dag() dagify(y ~ x, x ~ z, y ~ z) %>% tidy_dagitty(layout = "tree") %>% ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_edges_diagonal() + geom_dag_text() + theme_dag() + scale_adjus d = dagify(y ~ x, x ~ z, y ~ z) %>% tidy_dagitty(layout = "tree") p1 = d %>% filter(name == "z") %>% ggplot(aes(x = x, y = y, xend = xend, yend = yend)) + geom_dag_point() + geom_dag_edges(edge_linetype = "dashed") + geom_dag_text() + theme_dag() d2 = d %>% filter(name != "z") %>% ggdag() p1 + geom_dag_point(data = d2) # bootstrap from ungeviz repo library(gganimate) set.seed(69527) x <- rnorm(15) data <- data.frame( x, y = x + 0.5*rnorm(15) ) bs <- bootstrapper(9) library(ungeviz) bs <- bootstrapper(9) bs p <- ggplot(data, aes(x, y)) + geom_point(shape = 21, size = 6, fill = "white") + geom_text(label = "0", hjust = 0.5, vjust = 0.5, size = 10/.pt) + geom_point(data = bs, aes(group = .row), shape = 21, size = 6, fill = "blue") + geom_text( data = bs, aes(label = .copies, group = .row), hjust = 0.5, vjust = 0.5, size = 10/.pt, color = "white" ) + geom_smooth(data = bs, method = "lm", se = FALSE) + ggtitle("Bootstrap demonstration") + theme_bw() p + facet_wrap(~.draw) p + transition_states(.draw, 1, 1) + enter_fade() + exit_fade() # and groups by variable `KnownSex` bsr <- bootstrapper(20, KnownSex) ggplot(BlueJays, aes(BillLength, Head, color = KnownSex)) + geom_smooth(method = "lm", color = NA) + geom_point(alpha = 0.3) + # `.row` is a generated column providing a unique row number for all rows geom_point(data = bsr, aes(group = .row)) + geom_smooth(data = bsr, method = "lm", fullrange = TRUE, se = FALSE) + facet_wrap(~KnownSex, scales = "free_x") + scale_color_manual(values = c(F = "#D55E00", M = "#0072B2"), guide = "none") + theme_bw() + transition_states(.draw, 1, 1) + enter_fade() + exit_fade() data("wage1", package = "wooldridge") wage1$female = factor(wage1$female, labels = c("male","female")) bs <- bootstrapper(20, female) anim <- ggplot(wage1, aes(x = educ, y = lwage, color = female)) + geom_smooth(method = "lm", color = NA) + geom_point(alpha = 0.3) + # `.row` is a generated column providing a unique row number for all rows geom_point(data = bs, aes(group = .row)) + geom_smooth(data = bs, method = "lm", fullrange = TRUE, se = FALSE) + facet_wrap(~female, scales = "free_x") + scale_color_manual(values = c("male" = "#D55E00", "female" = "#0072B2"), guide = "none") + theme_bw() + transition_states(.draw, 1, 1) + enter_fade() + exit_fade() animate(anim, renderer = gifski_renderer()) ================================================ FILE: book.bib ================================================ @Book{xie2015, title = {Dynamic Documents with {R} and knitr}, author = {Yihui Xie}, publisher = {Chapman and Hall/CRC}, address = {Boca Raton, Florida}, year = {2015}, edition = {2nd}, note = {ISBN 978-1498716963}, url = {http://yihui.name/knitr/}, } @article{krueger1999, title={Experimental estimates of education production functions}, author={Krueger, Alan B}, journal={The quarterly journal of economics}, volume={114}, number={2}, pages={497--532}, year={1999}, publisher={MIT Press} } @article{pinotti, Author = {Pinotti, Paolo}, Title = {Clicking on Heaven's Door: The Effect of Immigrant Legalization on Crime}, Journal = {American Economic Review}, Volume = {107}, Number = {1}, Year = {2017}, Month = {January}, Pages = {138-68}, DOI = {10.1257/aer.20150355}, URL = {http://www.aeaweb.org/articles?id=10.1257/aer.20150355}} @article{freedman1991, title={Statistical models and shoe leather}, author={Freedman, David A}, journal={Sociological methodology}, pages={291--313}, year={1991}, publisher={JSTOR} } @book{deaton1997, title={The analysis of household surveys: a microeconometric approach to development policy}, author={Deaton, Angus}, year={1997}, publisher={The World Bank} } @article{angristlavy, title={Using Maimonides' rule to estimate the effect of class size on scholastic achievement}, author={Angrist, Joshua D and Lavy, Victor}, journal={The Quarterly journal of economics}, volume={114}, number={2}, pages={533--575}, year={1999}, publisher={MIT Press} } @article{angristkrueger, author = {Angrist, Joshua D. and Krueger, Alan B.}, title = {Does Compulsory School Attendance Affect Schooling and Earnings?}, journal = {The Quarterly Journal of Economics}, volume = {106}, number = {4}, pages = {979-1014}, year = {1991}, month = {11}, abstract = "{We establish that season of birth is related to educational attainment because of school start age policy and compulsory school attendance laws. Individuals born in the beginning of the year start school at an older age, and can therefore drop out after completing less schooling than individuals born near the end of the year. Roughly 25 percent of potential dropouts remain in school because of compulsory schooling laws. We estimate the impact of compulsory schooling on earnings by using quarter of birth as an instrument for education. The instrumental variables estimate of the return to education is close to the ordinary least squares estimate, suggesting that there is little bias in conventional estimates.}", issn = {0033-5533}, doi = {10.2307/2937954}, url = {https://doi.org/10.2307/2937954}, eprint = {https://academic.oup.com/qje/article-pdf/106/4/979/5298446/106-4-979.pdf}, } @article{angristkruegerIV, title={Instrumental variables and the search for identification: From supply and demand to natural experiments}, author={Angrist, Joshua D and Krueger, Alan B}, journal={Journal of Economic perspectives}, volume={15}, number={4}, pages={69--85}, year={2001} } ================================================ FILE: images/trade.html ================================================
Effects of Free Trade Agreements
Florian Oswald
11/10/2018
Setup
This exercise was developed by Thierry Mayer for the International Trade and Finance Course. The dataset needed for this exercise is available in Stata format at this dropbox link. Download the file, and read it into R with the function read_stata from the haven package.
Exploring the data
What variables are included in the data?
## [1] "year" "iso_o" "iso_d" "contig" "comlang_off" ## [6] "distw" "pop_o" "pop_d" "gdp_o" "gdp_d" ## [11] "comcur" "fta_wto" "flow"how many observations do we have in total?
## [1] 1106870 13How many unique countries do we have in the columns
iso_oandiso_d(origin/destination)?## [1] 208## [1] 208- How does the total number of observations evolve over the years? That is, how many rows of data do we have for each year?
- What about countries? How many countries
iso_odo we have by year?
How often does each country appear as
iso_dwithin a year? Make a table that counts how often each country appears asiso_dper year!## # A tibble: 1,106,870 x 3 ## # Groups: year [69] ## year iso_d n ## <dbl> <chr> <int> ## 1 1984 ABW 2 ## 2 1984 ABW 2 ## 3 1985 ABW 1 ## 4 1986 ABW 1 ## 5 1987 ABW 1 ## 6 1988 ABW 5 ## 7 1988 ABW 5 ## 8 1988 ABW 5 ## 9 1988 ABW 5 ## 10 1988 ABW 5 ## # ... with 1,106,860 more rowsDo all countries trade with each other? How many country pairs would we observe if each country traded with each other possible country? Produce a graph that illustrates cross country trade. You could think of a square matrix \(M\) with as many row and columns as there are unique countries. rows index
originand cols indexdestinationcountries. You could fill the the matrix like this, where \(i,j\) index origin and destination country:\[ M(i,j) = \begin{cases} 1 & \text{if flow}_{ij}>0 \\ 0 & \text{else.} \end{cases} \] Your graph should visualize this matrix somehow. Make the graph for two years, 1948 and 2016, and compute the share of trading countries in each of them.
Gravity
Compute a new variable called gravity, defined as
\[ \text{gravity}_{odt} = \frac{GDP_{ot} \cdot GDP_{dt}}{DGP_{wt}\cdot distance_{od}} \]
where indices \(o,d,t\) stand for origin, destination and year. The index \(w\) means world, i.e. here we talk about the sum of all destination countries. You need to be careful here because some countries don’t have any data in certain years (as we know from above), so there will be missing values. When you prepare this computation, apply the following cleaning protocol to your data:
- you need to be careful in computing world gdp. Look back at point 6. above for why. Using
dplyr, I would compute world gdp by year first, and then merge it back onto the main dataset. - group the data by year
- compute the share of
gdp_oandgdp_din world gdp and drop observations smaller than the first percentile of either share - transform
flowintoflow/1000i.e. trade flows in thousand dollars. - compute gravity as above.
Gravity Regression
Run a regression of the log of trade flows on the log of gravity, using only data for the year 1995. Interpret the coefficient obtained. In a scatterplot, represent the relationship between the log of trade flows on the log of the gravity prediction, together with the regression line, which is very close to a 45 degree line for the 1995 data. How should we interpret the distance of each point to this 45 degree line?
##
## Call:
## lm(formula = log(flow1000) ~ log(gravity), data = d95)
##
## Residuals:
## Min 1Q Median 3Q Max
## -12.836 -1.192 0.162 1.414 8.501
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -0.847702 0.052725 -16.08 <2e-16 ***
## log(gravity) 1.036308 0.005989 173.04 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 2.295 on 17801 degrees of freedom
## Multiple R-squared: 0.6272, Adjusted R-squared: 0.6271
## F-statistic: 2.994e+04 on 1 and 17801 DF, p-value: < 2.2e-16
How do the slope coefficient estimates vary by year? You could run the above regression for each year, collect the slopes, and plot them against year.
Effect of Free Trade Agreements
Do the same scatterplot, but highlighting in a different color the pairs of countries engaged in a Free Trade Agreement (fta_wto = 1 for those in the database). Is it clear what is the effect of agreements graphically? I used function dplyr::sample_frac to randomly select 10% of rows from the 1995 data in order to avoid overplotting.
Investigate this more with Regressions
Run the following regressions using the 1995 data as above.
A classical gravity equation with only GDPs and distance (in logs) explaining the log of trade flows. That is, instead of the computed
gravityvariable from above, we include the following variables individually: \[\begin{align} \log(gravity)_{odt} &= \log\left( \frac{GDP_{ot} \cdot GDP_{dt}}{ distance_{od}}\right) \\ &= \log(GDP_{ot}) + \log(GDP_{dt}) - \log(GDP_{dt}) - \log(distance_{od}) \end{align}\] and so you are supposed to investigate \[ \log \left( \frac{flow_{odt}}{1000} \right) = \log(GDP_{ot}) + \log(GDP_{dt} - \log(distance_{od}) \]Introduce the
fta_wtodummy variable in that regression. What is the impact of becoming awtomember on expected trade flows? To answer that last question, remember that for a zero-one dummy \(d\) , \[\begin{align} \ln y &= a + b d \\ y =&= \exp(a +b d) \\ E[y|d=0] =& \exp(a)\\ E[y|d=1] =& \exp(a + b )\\ \Delta E[y|d] =& \exp(a + b ) - \exp(a)\\ \%\Delta E[y|d] =& \frac{\exp(a + b ) - \exp(a)}{\exp(a)}\\ =& e^{a + b - a} - 1 = \exp( b ) - 1 \end{align}\]Introduce common language and contiguity. Again compute the impact of having a common official language and of being contiguous contries.