This is a simulation to demonstrate the power of instrumental variables. This code is based on the simulation shown on this blog.

The purpose of doing a simulation is to show you how instrumental variables work. Because, if you’re like me, you thought they were a little too magical when you first saw this.

Let’s say we have some outcome variable \(Y\). It is a function of two variables, \(X\) and \(W\). We are interested in knowing the causal effect of \(X\) on \(Y\).

Our model is such:

\[ E(Y) = \beta_0 + \beta_1 X + \beta_2 W \]

Now, let’s assume that \(X\) and \(W\) are correlated with one another because \(W\) is also a cause of \(X\). However, for whatever reason we don’t actually observed or measure \(W\). If we were omniscient, we would have collected \(W\) and we could then just fit a regression of \(Y\) on \(X\) and \(W\) and get an unbiased estimated of \(X\). However, we don’t have \(W\), so we just fit regress \(Y\) on \(X\) using lm(Y ~ X).

This model impies that are observations of \(Y\) are such that:

\[ Y_i = \beta_0 + \beta_1 X_i + \epsilon_i\]

But our problem is that our error term is a function of the missing \(W\) and residual error, \(e_i\). \[ \epsilon_i = f(W_i, e_i)\]

Because of this \(X_i\) and \(e_i\) are correlated and we’ll end up biased estimates of \(\beta_1\), which is the causal effect of \(X\) on \(Y\).

What we need is an instrumental variable, \(Z\), that is a partial cause of \(X\) but has no direct relationship with \(Y\) only an indirect relationship through \(X\).

\[ E(X) = \alpha_0 + \alpha_1 X_i^{*} + \alpha_2\]

If we estimate, the equations:

\[ Y_i = \beta_0 + \beta_1 X + e_1\] \[ X_i = \alpha_0 + \alpha_1 Z + e_2\]

and allow the \(Cov(e_1, e_2)\) to be freely estimated, we’ll get an unbiased estimate of \(\beta_1\).

Let’s try this out with a simulation. First we’ll generate the data.

Now, if we fit the following path model, we’ll get an unbiased estimate of

set.seed(523123)
## Load the required libraries ---------------
library("lavaan")
library("MASS")
library("semPlot")

# Generate X* and W as correlated normal random variables ------------
pred.vars <- mvrnorm(10000, c(20, 15), matrix(c(1, 0.75, 0.75, 1), 2, 2))
x.star <- pred.vars[, 1]  
W <- pred.vars[, 2]

# Next generate the instrumental variable -----------------
Z <- rnorm(10000)
X <- x.star + Z

# Note the x.star part is the part of X that is unexplained by Z and contains
# the residual error.

# Finally, let's generate our outcome variable Y -----------------
# Note, it's a function of:
# - beta0 = 1
# - beta1 = 1
# - beta2 = 1
# - residual ~ N(0, 0.5^2)
Y <- 1 + X + W + rnorm(10000, 0, 0.5)

# Then we save our data set
iv.data <- data.frame(X, Y, Z, W)

First, let’s view the true model in lavaan

And let’s view the model output.

summary(fit.true)
lavaan (0.5-20) converged normally after  24 iterations

  Number of observations                         10000

  Estimator                                         ML
  Minimum Function Test Statistic                0.000
  Degrees of freedom                                 0
  Minimum Function Value               0.0000000000000

Parameter Estimates:

  Information                                 Expected
  Standard Errors                             Standard

Regressions:
                   Estimate  Std.Err  Z-value  P(>|z|)
  X ~                                                 
    W                 0.760    0.012   63.365    0.000
  Y ~                                                 
    X                 0.990    0.004  239.396    0.000
    W                 0.997    0.006  169.882    0.000

Variances:
                   Estimate  Std.Err  Z-value  P(>|z|)
    X                 1.458    0.021   70.711    0.000
    Y                 0.249    0.004   70.711    0.000

What would our estimate of \(\beta_1\) be without W? Our estimate is 0.99 for the true parameter of 1.

lm(Y ~ X, data = iv.data)

Call:
lm(formula = Y ~ X, data = iv.data)

Coefficients:
(Intercept)            X  
      8.686        1.366  

Ouch! 1.366 is much further from 1 than 0.99!

Let’s see if we can do better with our instrumental variable Z.

summary(fit.iv)
lavaan (0.5-20) converged normally after  18 iterations

  Number of observations                         10000

  Estimator                                         ML
  Minimum Function Test Statistic                0.000
  Degrees of freedom                                 0
  Minimum Function Value               0.0000000000000

Parameter Estimates:

  Information                                 Expected
  Standard Errors                             Standard

Regressions:
                   Estimate  Std.Err  Z-value  P(>|z|)
  X ~                                                 
    Z                 1.002    0.010   98.975    0.000
  Y ~                                                 
    X                 0.992    0.011   89.044    0.000

Covariances:
                   Estimate  Std.Err  Z-value  P(>|z|)
  X ~~                                                
    Y                 0.764    0.018   42.718    0.000

Variances:
                   Estimate  Std.Err  Z-value  P(>|z|)
    X                 1.032    0.015   70.711    0.000
    Y                 1.254    0.025   51.019    0.000

The estimate from the true model was .990 and from our IV model was 0.992. This is much closer to the truth!

Now let’s run this as a full blown simulation with 2000 replicates!

summary(true.fit)
     Length Class  Mode
[1,] 1      lavaan S4  
[2,] 1      lavaan S4  
LS0tCnRpdGxlOiAiSW5zdHJ1bWVudGFsIFZhcmlhYmxlcyIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKVGhpcyBpcyBhIHNpbXVsYXRpb24gdG8gZGVtb25zdHJhdGUgdGhlIHBvd2VyIG9mIGluc3RydW1lbnRhbCB2YXJpYWJsZXMuIFRoaXMgY29kZSBpcyBiYXNlZCBvbiB0aGUgc2ltdWxhdGlvbiBzaG93biBvbiBbdGhpcyBibG9nXShodHRwOi8vamFjb2JzaW1tZXJpbmcuY29tLzIwMTQvMDEvMTAvSW5zdHJ1bWVudGFsVmFyaWFibGVzLykuCgpUaGUgcHVycG9zZSBvZiBkb2luZyBhIHNpbXVsYXRpb24gaXMgdG8gc2hvdyB5b3UgaG93IGluc3RydW1lbnRhbCB2YXJpYWJsZXMgd29yay4gQmVjYXVzZSwgaWYgeW91J3JlIGxpa2UgbWUsIHlvdSB0aG91Z2h0IHRoZXkgd2VyZSBhIGxpdHRsZSB0b28gbWFnaWNhbCB3aGVuIHlvdSBmaXJzdCBzYXcgdGhpcy4gCgpMZXQncyBzYXkgd2UgaGF2ZSBzb21lIG91dGNvbWUgdmFyaWFibGUgJFkkLiBJdCBpcyBhIGZ1bmN0aW9uIG9mIHR3byB2YXJpYWJsZXMsICRYJCBhbmQgJFckLiBXZSBhcmUgaW50ZXJlc3RlZCBpbiBrbm93aW5nIHRoZSBjYXVzYWwgZWZmZWN0IG9mICRYJCBvbiAkWSQuCgpPdXIgbW9kZWwgaXMgc3VjaDoKCiQkIEUoWSkgPSBcYmV0YV8wICsgXGJldGFfMSBYICsgXGJldGFfMiBXICQkCgpOb3csIGxldCdzIGFzc3VtZSB0aGF0ICRYJCBhbmQgJFckIGFyZSBjb3JyZWxhdGVkIHdpdGggb25lIGFub3RoZXIgYmVjYXVzZSAkVyQgaXMgYWxzbyBhIGNhdXNlIG9mICRYJC4gSG93ZXZlciwgZm9yIHdoYXRldmVyIHJlYXNvbiB3ZSBkb24ndCBhY3R1YWxseSBvYnNlcnZlZCBvciBtZWFzdXJlICRXJC4gSWYgd2Ugd2VyZSBvbW5pc2NpZW50LCB3ZSB3b3VsZCBoYXZlIGNvbGxlY3RlZCAkVyQgYW5kIHdlIGNvdWxkIHRoZW4ganVzdCBmaXQgYSByZWdyZXNzaW9uIG9mICAkWSQgb24gJFgkIGFuZCAkVyQgYW5kIGdldCBhbiB1bmJpYXNlZCBlc3RpbWF0ZWQgb2YgJFgkLiBIb3dldmVyLCB3ZSBkb24ndCBoYXZlICRXJCwgc28gd2UganVzdCBmaXQgcmVncmVzcyAkWSQgb24gJFgkIHVzaW5nIGBsbShZIH4gWClgLgoKVGhpcyBtb2RlbCBpbXBpZXMgdGhhdCBhcmUgb2JzZXJ2YXRpb25zIG9mICRZJCBhcmUgc3VjaCB0aGF0OgoKJCQgWV9pID0gXGJldGFfMCArIFxiZXRhXzEgWF9pICsgXGVwc2lsb25faSQkCgpCdXQgb3VyIHByb2JsZW0gaXMgdGhhdCBvdXIgZXJyb3IgdGVybSBpcyBhIGZ1bmN0aW9uIG9mIHRoZSBtaXNzaW5nICRXJCBhbmQgcmVzaWR1YWwgZXJyb3IsICRlX2kkLgokJCBcZXBzaWxvbl9pID0gZihXX2ksIGVfaSkkJAoKQmVjYXVzZSBvZiB0aGlzICRYX2kkIGFuZCAkZV9pJCBhcmUgY29ycmVsYXRlZCBhbmQgd2UnbGwgZW5kIHVwIGJpYXNlZCBlc3RpbWF0ZXMgb2YgJFxiZXRhXzEkLCB3aGljaCBpcyB0aGUgY2F1c2FsIGVmZmVjdCBvZiAkWCQgb24gJFkkLiAKCldoYXQgd2UgbmVlZCBpcyBhbiBpbnN0cnVtZW50YWwgdmFyaWFibGUsICRaJCwgdGhhdCBpcyBhIHBhcnRpYWwgY2F1c2Ugb2YgJFgkIGJ1dCBoYXMgbm8gZGlyZWN0IHJlbGF0aW9uc2hpcCB3aXRoICRZJCBvbmx5IGFuIGluZGlyZWN0IHJlbGF0aW9uc2hpcCB0aHJvdWdoICRYJC4gCgokJCBFKFgpID0gXGFscGhhXzAgKyBcYWxwaGFfMSBYX2leeyp9ICsgXGFscGhhXzIkJAoKSWYgd2UgZXN0aW1hdGUsIHRoZSBlcXVhdGlvbnM6CgokJCBZX2kgPSBcYmV0YV8wICsgXGJldGFfMSBYICsgZV8xJCQKJCQgWF9pID0gXGFscGhhXzAgKyBcYWxwaGFfMSBaICsgZV8yJCQKCmFuZCBhbGxvdyB0aGUgJENvdihlXzEsIGVfMikkIHRvIGJlIGZyZWVseSBlc3RpbWF0ZWQsIHdlJ2xsIGdldCBhbiB1bmJpYXNlZCBlc3RpbWF0ZSBvZiAkXGJldGFfMSQuCgpMZXQncyB0cnkgdGhpcyBvdXQgd2l0aCBhIHNpbXVsYXRpb24uIEZpcnN0IHdlJ2xsIGdlbmVyYXRlIHRoZSBkYXRhLgoKTm93LCBpZiB3ZSBmaXQgdGhlIGZvbGxvd2luZyBwYXRoIG1vZGVsLCB3ZSdsbCBnZXQgYW4gdW5iaWFzZWQgZXN0aW1hdGUgb2YgCgpgYGB7cn0Kc2V0LnNlZWQoNTIzMTIzKQojIyBMb2FkIHRoZSByZXF1aXJlZCBsaWJyYXJpZXMgLS0tLS0tLS0tLS0tLS0tCmxpYnJhcnkoImxhdmFhbiIpCmxpYnJhcnkoIk1BU1MiKQpsaWJyYXJ5KCJzZW1QbG90IikKCiMgR2VuZXJhdGUgWCogYW5kIFcgYXMgY29ycmVsYXRlZCBub3JtYWwgcmFuZG9tIHZhcmlhYmxlcyAtLS0tLS0tLS0tLS0KcHJlZC52YXJzIDwtIG12cm5vcm0oMTAwMDAsIGMoMjAsIDE1KSwgbWF0cml4KGMoMSwgMC43NSwgMC43NSwgMSksIDIsIDIpKQp4LnN0YXIgPC0gcHJlZC52YXJzWywgMV0gIApXIDwtIHByZWQudmFyc1ssIDJdCgojIE5leHQgZ2VuZXJhdGUgdGhlIGluc3RydW1lbnRhbCB2YXJpYWJsZSAtLS0tLS0tLS0tLS0tLS0tLQpaIDwtIHJub3JtKDEwMDAwKQpYIDwtIHguc3RhciArIFoKCiMgTm90ZSB0aGUgeC5zdGFyIHBhcnQgaXMgdGhlIHBhcnQgb2YgWCB0aGF0IGlzIHVuZXhwbGFpbmVkIGJ5IFogYW5kIGNvbnRhaW5zCiMgdGhlIHJlc2lkdWFsIGVycm9yLgoKIyBGaW5hbGx5LCBsZXQncyBnZW5lcmF0ZSBvdXIgb3V0Y29tZSB2YXJpYWJsZSBZIC0tLS0tLS0tLS0tLS0tLS0tCiMgTm90ZSwgaXQncyBhIGZ1bmN0aW9uIG9mOgojIC0gYmV0YTAgPSAxCiMgLSBiZXRhMSA9IDEKIyAtIGJldGEyID0gMQojIC0gcmVzaWR1YWwgfiBOKDAsIDAuNV4yKQpZIDwtIDEgKyBYICsgVyArIHJub3JtKDEwMDAwLCAwLCAwLjUpCgojIFRoZW4gd2Ugc2F2ZSBvdXIgZGF0YSBzZXQKaXYuZGF0YSA8LSBkYXRhLmZyYW1lKFgsIFksIFosIFcpCmBgYAoKRmlyc3QsIGxldCdzIHZpZXcgdGhlIHRydWUgbW9kZWwgaW4gbGF2YWFuCgpgYGB7cn0KdHJ1ZS5tb2RlbCA8LSAnCiBYIH4gVwogWSB+IFggKyBXCicKZml0LnRydWUgPC0gc2VtKHRydWUubW9kZWwsIGl2LmRhdGEpCnNlbVBhdGhzKGZpdC50cnVlKQpgYGAKCkFuZCBsZXQncyB2aWV3IHRoZSBtb2RlbCBvdXRwdXQuCgpgYGB7cn0Kc3VtbWFyeShmaXQudHJ1ZSkKYGBgCgpXaGF0IHdvdWxkIG91ciBlc3RpbWF0ZSBvZiAkXGJldGFfMSQgYmUgd2l0aG91dCBXPyBPdXIgZXN0aW1hdGUgaXMgMC45OSBmb3IgdGhlIHRydWUgcGFyYW1ldGVyIG9mIDEuIAoKYGBge3J9CmxtKFkgfiBYLCBkYXRhID0gaXYuZGF0YSkKYGBgCgpPdWNoISAxLjM2NiBpcyBtdWNoIGZ1cnRoZXIgZnJvbSAxIHRoYW4gMC45OSEKCkxldCdzIHNlZSBpZiB3ZSBjYW4gZG8gYmV0dGVyIHdpdGggb3VyIGluc3RydW1lbnRhbCB2YXJpYWJsZSBaLgoKYGBge3J9Cml2Lm1vZGVsIDwtICcKIFggfiBaCiBYIH5+IFkKIFkgfiBYIAonCmZpdC5pdiA8LSBzZW0oaXYubW9kZWwsIGl2LmRhdGEpCnNlbVBhdGhzKGZpdC5pdikKYGBgCgpgYGB7cn0Kc3VtbWFyeShmaXQuaXYpCmBgYAoKVGhlIGVzdGltYXRlIGZyb20gdGhlIHRydWUgbW9kZWwgd2FzIC45OTAgYW5kIGZyb20gb3VyIElWIG1vZGVsIHdhcyAwLjk5Mi4gVGhpcyBpcyBtdWNoIGNsb3NlciB0byB0aGUgdHJ1dGghCgpOb3cgbGV0J3MgcnVuIHRoaXMgYXMgYSBmdWxsIGJsb3duIHNpbXVsYXRpb24gd2l0aCAyMDAwIHJlcGxpY2F0ZXMhCgpgYGB7cn0KCk4gPC0gMgpvYnMgPC0gMTAwMAp0cnVlLmZpdCA8LSBsaXN0KCkKaXYuZml0IDwtIGxpc3QoKQpiaWFzZWQuZml0IDwtIGxpc3QoKQoKCmZvcihpIGluIDE6Til7CiMgR2VuZXJhdGUgWCogYW5kIFcgYXMgY29ycmVsYXRlZCBub3JtYWwgcmFuZG9tIHZhcmlhYmxlcyAtLS0tLS0tLS0tLS0KcHJlZC52YXJzIDwtIG12cm5vcm0ob2JzLCBjKDIwLCAxNSksIG1hdHJpeChjKDEsIDAuNzUsIDAuNzUsIDEpLCAyLCAyKSkKeC5zdGFyIDwtIHByZWQudmFyc1ssIDFdICAKVyA8LSBwcmVkLnZhcnNbLCAyXQoKIyBOZXh0IGdlbmVyYXRlIHRoZSBpbnN0cnVtZW50YWwgdmFyaWFibGUgLS0tLS0tLS0tLS0tLS0tLS0KWiA8LSBybm9ybShvYnMpClggPC0geC5zdGFyICsgWgoKIyBOb3RlIHRoZSB4LnN0YXIgcGFydCBpcyB0aGUgcGFydCBvZiBYIHRoYXQgaXMgdW5leHBsYWluZWQgYnkgWiBhbmQgY29udGFpbnMKIyB0aGUgcmVzaWR1YWwgZXJyb3IuCgojIEZpbmFsbHksIGxldCdzIGdlbmVyYXRlIG91ciBvdXRjb21lIHZhcmlhYmxlIFkgLS0tLS0tLS0tLS0tLS0tLS0KIyBOb3RlLCBpdCdzIGEgZnVuY3Rpb24gb2Y6CiMgLSBiZXRhMCA9IDEKIyAtIGJldGExID0gMQojIC0gYmV0YTIgPSAxCiMgLSByZXNpZHVhbCB+IE4oMCwgMC41XjIpClkgPC0gMSArIFggKyBXICsgcm5vcm0ob2JzLCAwLCAwLjUpCgojIFNhdmUgdGhlIGRhdGEKaXYuZGF0YSA8LSBkYXRhLmZyYW1lKFgsIFksIFosIFcpCmhlYWQoaXYuZGF0YSkKdHJ1ZS5maXRbW2ldXSA8LSBzZW0odHJ1ZS5tb2RlbCwgaXYuZGF0YSkKaXYuZml0W1tpXV0gPC0gc2VtKGl2Lm1vZGVsLCBpdi5kYXRhKQpiaWFzZWQuZml0W1tpXV0gPC0gbG0oWSB+IFgsIGRhdGEgPSBpdi5kYXRhKQp9CmBgYAoKCg==