I am working on the chimpanzees dataset from Richard Mclearth's text, "Statistical Rethinking", edition 2.
I have built 2 simple models, one a fixed effects model and the other a hierarchical model.
library(modelr)
library(gridExtra)
library(rethinking)
data(chimpanzees)
d <- chimpanzees
rm(chimpanzees)
detach(package:rethinking, unload = T)
library(brms)
d$treatment <- 1 + d$prosoc_left + 2 * d$condition
d$treatment <- as.factor(d$treatment)
d$pulled_left <- as.factor(d$pulled_left)
d$actor <- as.factor(d$actor)
d$block <- as.factor(d$block)
The first fixed effects model
priors <- c(prior(normal(0, 0.5), class = b))
bm_11.4 <- brm(data = d, family = bernoulli,
formula = pulled_left ~ 1 + actor + treatment,
sample_prior = T, prior = priors,
cores = 4, chains = 4)
Another a hierarchical model
bm_11.5 <- brm(data = d, family = bernoulli,
formula = pulled_left ~ 1 + (1|actor) + (1|treatment),
sample_prior = T, #prior = priors,
cores = 4, chains = 4,
control = list(adapt_delta = 0.95))
When I take a look at the predictions based on the posterior draws using the following code
p1 <- d %>%
data_grid(actor, treatment) %>%
add_fitted_draws(bm_11.4) %>%
median_qi(.value) %>%
ggplot(aes(x = .value, y = treatment)) + geom_pointintervalh() + facet_wrap(actor~.) +
ggtitle("Fixed Effects model")
p2 <- d %>%
data_grid(actor, treatment) %>%
add_fitted_draws(bm_11.5) %>%
median_qi(.value) %>%
ggplot(aes(x = .value, y = treatment)) + geom_pointintervalh() + facet_wrap(actor~.) +
ggtitle("Random effects model")
grid.arrange(p1, p2, nrow = 1)
I get the following graph
For the actor #2, the chimpanzee always pulls the left level and hence the probability of pulling the left level is closer to 1, in both the models. However, given the shrinkage I expected that the hierarchical model would be pulled away from 1 and not the fixed effects model. I would like to understand this behavior, please help.