Chapter 6 - The Haunted DAG & the Causal Terror

Multiple regression is no oracle, but only a golem. It is logical, but the relationships it describes are conditional associations, not causal influences. Therefore additional information, from outside the model, is needed to make sense of it. This chapter presented introductory examples of some common frustrations: multi-collinearity, post-treatment bias, and collider bias. Solutions to these frustrations can be organized under a coherent framework in which hypothetical causal relations among variables are analyzed to cope with confounding. In all cases, causal models exist outside the statistical model and can be difficult to test. However, it is possible to reach valid causal inferences in the absence of experiments. This is good news, because we often cannot perform experiments, both for practical and ethical reasons.

Place each answer inside the code chunk (grey box). The code chunks should contain a text response or a code that completes/answers the question or activity requested. Make sure to include plots if the question requests them.

Finally, upon completion, name your final output .html file as: YourName_ANLY505-Year-Semester.html and publish the assignment to your R Pubs account and submit the link to Canvas. Each question is worth 5 points.

Questions

6-1. Use the Waffle House data, data(WaffleDivorce), to find the total causal influence of number of Waffle Houses on divorce rate. Justify your model or models with a causal graph (draw a DAG).

waffle_dag <- dagitty("dag { S -> W -> D <- A <- S -> M -> D; A -> M }")
coordinates(waffle_dag) <- list(x = c(A = 1, S = 1, M = 2, W = 3, D = 3),
                                y = c(A = 1, S = 3, M = 2, W = 3, D = 1))
drawdag(waffle_dag)

#To estimate the causal effect of Waffle Houses (W) on divorce rate (D), we need to condition on either S or A and M both. Let us try conditioning on S.

adjustmentSets(waffle_dag, exposure = "W", outcome = "D")
## { A, M }
## { S }
#> { A, M }
#> { S }

data("WaffleDivorce")
data <- WaffleDivorce

model <- quap(
  alist(
    Divorce ~ dnorm(mu, sigma),
    mu <- a + bS * South + bW * WaffleHouses,
    a ~ dnorm(0, 0.2),
    c(bS, bW) ~ dnorm(0, 0.5),
    sigma ~ dexp(1)
  ),
  data = data
)
precis(model)
##             mean        sd        5.5%      94.5%
## a     0.24107434 0.2021224 -0.08195623 0.56410491
## bS    0.21518777 0.4954590 -0.57665145 1.00702699
## bW    0.06218667 0.0154995  0.03741548 0.08695786
## sigma 7.82234394 0.7228109  6.66715259 8.97753528

6-2. Build a series of models to test the implied conditional independencies of the causal graph you used in the previous problem. If any of the tests fail, how do you think the graph needs to be amended? Does the graph need more or fewer arrows? Feel free to nominate variables that aren’t in the data.

impliedConditionalIndependencies(waffle_dag)
## A _||_ W | S
## D _||_ S | A, M, W
## M _||_ W | S
model_1 <- quap(
alist(
    MedianAgeMarriage ~ dnorm(mu, sigma),
    mu <- a + bS * South + bW * WaffleHouses,
    a ~ dnorm(0, 0.2),
    c(bS, bW) ~ dnorm(0, 0.5),
    sigma ~ dexp(1))
  ,
  data = data
)
precis(model_1)
##              mean         sd        5.5%      94.5%
## a      0.10711758 0.20030749 -0.21301246  0.4272476
## bS     0.08252384 0.49920382 -0.71530028  0.8803480
## bW     0.15553032 0.03841548  0.09413496  0.2169257
## sigma 19.75056927 1.57126281 17.23938782 22.2617507
model_2 <- quap(
  alist(
    Divorce ~ dnorm(mu, sigma),
    mu <- a + bA * MedianAgeMarriage + bS * South + bM * Marriage + bW * WaffleHouses,
    a ~ dnorm(0, 0.2),
    c(bA, bS, bM, bW) ~ dnorm(0, 0.5),
    sigma ~ dexp(1)
  ),
  data = data
)
precis(model_2)
##              mean          sd         5.5%      94.5%
## a     0.019662946 0.199960912 -0.299913211 0.33923910
## bA    0.168836274 0.040731631  0.103739260 0.23393329
## bS    0.406146602 0.412925851 -0.253788661 1.06608186
## bM    0.246464045 0.051517287  0.164129471 0.32879862
## bW    0.005316515 0.004057997 -0.001168949 0.01180198
## sigma 1.639947823 0.161497509  1.381843611 1.89805203
model_3 <- quap(
  alist(
    Marriage ~ dnorm(mu, sigma),
    mu <- a + bS * South + bW * WaffleHouses,
    a ~ dnorm(0, 0.2),
    c(bS, bW) ~ dnorm(0, 0.5),
    sigma ~ dexp(1)
  ),
  data = data
)
precis(model_3)
##             mean         sd        5.5%      94.5%
## a      0.1267892 0.20045205 -0.19357188  0.4471503
## bS     0.1059574 0.49881614 -0.69124712  0.9031620
## bW     0.1224508 0.03098113  0.07293696  0.1719646
## sigma 15.8855020 1.31520166 13.78355573 17.9874483

6-3. For the DAG you made in the previous problem, can you write a data generating simulation for it? Can you design one or more statistical models to produce causal estimates? If so, try to calculate interesting counterfactuals. If not, use the simulation to estimate the size of the bias you might expect. Under what conditions would you, for example, infer the opposite of a true causal effect?

# showcasing simulation data:
N <-50000
set.seed(123)
consumption <-rnorm(N,10,3) 
production <-consumption*rnorm(N,0,2)+rnorm(N,10,3)
price <-consumption - production + rnorm(N,0,2)
data2 <-data.frame(consumption,production,price)

# Causal model and close the backdoor
model_4 <- quap(
alist(
    price ~ dnorm(mu, sigma),
    mu <- a + bD * consumption + bS * production,
    a ~ dnorm(0, 1),
    c(bD, bS) ~ dnorm(0, 2),
    sigma ~ dexp(1))
  ,
  data = data2
)
precis(model_4)
##               mean          sd        5.5%       94.5%
## a      0.001632909 0.031492266 -0.04869782  0.05196363
## bD     1.002050653 0.002989124  0.99727346  1.00682785
## bS    -1.000808625 0.000425442 -1.00148856 -1.00012869
## sigma  2.006203306 0.006343963  1.99606443  2.01634218

All three problems below are based on the same data. The data in data(foxes) are 116 foxes from 30 different urban groups in England. These foxes are like street gangs. Group size varies from 2 to 8 individuals. Each group maintains its own urban territory. Some territories are larger than others. The area variable encodes this information. Some territories also have more avgfood than others. We want to model the weight of each fox. For the problems below, assume the following DAG:

6-4. Use a model to infer the total causal influence of area on weight. Would increasing the area available to each fox make it heavier (healthier)? You might want to standardize the variables. Regardless, use prior predictive simulation to show that your model’s prior predictions stay within the possible outcome range.

data("foxes")

library(dplyr)
library(tidyverse)

test_independence <- function(model.input, coeff.input, depth.output = 1){
  suppressWarnings(
    precis(model.input, depth = depth.output) %>%
    as_tibble(rownames = "estimate") %>%
    filter(estimate %in% {{coeff.input}}) %>%
    mutate(across(where(is.numeric), round, digits = 2)) %>%
    knitr::kable()
  )
}

dat_foxes <- foxes %>% 
  as_tibble() %>% 
  mutate(across(-group, standardize))

m_foxes1 <- alist(weight ~ dnorm(mu, sigma),  
                  mu <- a + Barea*area, 
                  a ~ dnorm(0, 0.2), 
                  Barea ~ dnorm(0, 0.5), 
                  sigma ~ dexp(1)) %>% 
  quap(data = dat_foxes)

m_foxes1 %>% 
  extract.prior() %>% 
  link(m_foxes1, post = .,
    data = list(area = seq(-2, 2, length.out = 20))) %>% 
  as_tibble() %>%
  pivot_longer(cols = everything(), values_to = "weight") %>%
  add_column(
    area = rep(seq(-2, 2, length.out = 20), 1000),
    type = rep(as.character(1:1000), each = 20)) %>% 
  ggplot() +
  geom_line(aes(x = area, y = weight, group = type), 
            alpha = 0.1, colour = "blue") +
  labs(x = "Area (std)", y = "Weight (std)", 
       caption = "Prior predictive simulation for standardised area on weight.") +
  theme_minimal()

# area on weight
m_foxes1 %>% 
  test_independence(coeff.input = "Barea")
estimate mean sd 5.5% 94.5%
Barea 0.02 0.09 -0.13 0.16 
# There is no significant association between area and weight.

6-5. Now infer the causal impact of adding food to a territory. Would this make foxes heavier? Which covariates do you need to adjust for to estimate the total causal influence of food?

# There are two paths:
# 1) avgfood -> groupsize -> weight
# 2) avgfood -> weight
# Both paths are open and we want to keep both to infer the total causal impact of food on fox weight. We do not want to include group size because that would close the first path. A single predictor, food, is enough.

# Food on weight
alist(weight ~ dnorm(mu, sigma),  
                  mu <- a + Bavgf*avgfood, 
                  a ~ dnorm(0, 0.2), 
                  Bavgf ~ dnorm(0, 0.5), 
                  sigma ~ dexp(1)) %>% 
  quap(data = dat_foxes) %>% 
  test_independence(coeff.input = "Bavgf")
estimate mean sd 5.5% 94.5%
Bavgf -0.02 0.09 -0.17 0.12 
# There is no significant relationship between avgfood and fox weight.

6-6. Now infer the causal impact of group size. Which covariates do you need to adjust for? Looking at the posterior distribution of the resulting model, what do you think explains these data? That is, can you explain the estimates for all three problems? How do they go together?

# There are two paths:
# 1) groupsize -> weight
# 2) groupsize -> avgfood -> weight (This is a backdoor path and we want to close it.)

# Group size on weight
alist(weight ~ dnorm(mu, sigma),  
                  mu <- a + Bavgf*avgfood + Bgrps*groupsize, 
                  a ~ dnorm(0, 0.2), 
                  c(Bavgf, Bgrps) ~ dnorm(0, 0.5), 
                  sigma ~ dexp(1)) %>% 
  quap(data = dat_foxes) %>% 
  test_independence(coeff.input = c("Bavgf","Bgrps"))
estimate mean sd 5.5% 94.5%
Bavgf 0.48 0.18 0.19 0.76
Bgrps -0.57 0.18 -0.86 -0.29

6-7. Sometimes, in order to avoid multicollinearity, people inspect pairwise correlations among predictors before including them in a model. This is a bad procedure, because what matters is the conditional association, not the association before the variables are included in the model. To highlight this, consider the DAG X → Z → Y. Simulate data from this DAG so that the correlation between X and Z is very large. Then include both in a model prediction Y. Do you observe any multicollinearity? Why or why not? What is different from the legs example in the chapter?

N = 100
X = rnorm(N, mean = 0, sd = 1)
Z = rnorm(N, mean = X, sd = 0.5)
Y = rnorm(N, mean = Z, sd = 1)
data <- data.frame(X, Y, Z)
cor(X,Z)
## [1] 0.863121
# The output indicates the correlation between X and Z is high, so multicollinearity exists in this case. 

# Simulation
model <- quap(alist(
Y ~ dnorm( mu , sigma ) ,
mu <- a + bl*X + br*Z , 
a ~ dnorm( 1, 30 ) ,
bl ~ dnorm( 2 , 10 ) ,
br ~ dnorm( 2 , 10 ) ,
sigma ~ dexp( 1 )
), data=data) 
precis(model)
##            mean         sd        5.5%     94.5%
## a     0.1159748 0.09953312 -0.04309836 0.2750479
## bl    0.2073986 0.22225020 -0.14780016 0.5625973
## br    0.8371707 0.19529177  0.52505673 1.1492847
## sigma 0.9922537 0.06964501  0.88094754 1.1035599
# Leg
legs = quap(
  alist(
    Y ~ dnorm(mu,sigma),
    mu<-a+bX*X+bZ*Z,
    c(a,bX,bZ)~dnorm(0,1),
    sigma~dexp(1)
  ), data=list(X=X,Y=Y,Z=Z)
)

precis(legs)
##            mean         sd        5.5%     94.5%
## a     0.1139715 0.09904338 -0.04431894 0.2722620
## bX    0.2259562 0.21421237 -0.11639652 0.5683089
## bZ    0.8150736 0.18850196  0.51381105 1.1163361
## sigma 0.9923355 0.06966121  0.88100343 1.1036676
plot(precis(legs))