10.Rmd

```{r, echo = FALSE, cache = FALSE}
knitr::opts_chunk$set(fig.retina = 2.5)
options(width = 110)
```

# Counting and Classification

> All over the world, every day, scientists throw away information. Sometimes this is through the removal of "outliers," cases in the data that offend the model and are exiled. More routinely, counted things are converted to proportions before analysis. Why does analysis of proportions throw away information? Because 10/20 and ½ are the same proportion, one-half, but have very different sample sizes. Once converted to proportions, and treated as outcomes in a linear regression, the information about sample size has been destroyed.
>
> It's easy to retain the information about sample size. All that is needed is to model what has actually been observed, the counts instead of the proportions. [@mcelreathStatisticalRethinkingBayesian2015, p. 291]

In this chapter, we focus on the two most common types of count models: the binomial and the Poisson.

Side note: For a nice Bayesian way to accommodate outliers in your Gaussian models, check out my blog post, [*Robust linear regression with Student's $t$-distribution*](https://solomonkurz.netlify.app/blog/2019-02-02-robust-linear-regression-with-student-s-t-distribution/).

## Binomial regression

The basic binomial model follows the form

$$y \sim \operatorname{Binomial}(n, p),$$

where $y$ is some count variable, $n$ is the number of trials, and $p$ it the probability a given trial was a 1, which is sometimes termed a *success*. When $n = 1$, then $y$ is a vector of 0s and 1s. Presuming the logit link, which we just covered in [Chapter 9][Linking linear models to distributions.], models of this type are commonly termed logistic regression. When $n > 1$, and still presuming the logit link, we might call our model an aggregated logistic regression model, or more generally an aggregated binomial regression model.

### Logistic regression: Prosocial chimpanzees.

Load the @silkChimpanzeesAreIndifferent2005 `chimpanzees` data.

```{r, message = F, warning = F}
library(rethinking)
data(chimpanzees)
d <- chimpanzees
```

Switch from rethinking to brms.

```{r, message = F, warning = F}
detach(package:rethinking, unload = T)
library(brms)
rm(chimpanzees)
```
 
We start with the simple intercept-only logistic regression model, which follows the statistical formula

\begin{align*}
\text{pulled_left}_i      & \sim \operatorname{Binomial}(1, p_i) \\
\operatorname{logit}(p_i) & = \alpha \\
\alpha                    & \sim \operatorname{Normal}(0, 10).
\end{align*}

In the `brm()` `formula` syntax, including a `|` bar on the left side of a formula indicates we have extra supplementary information about our criterion. In this case, that information is that each `pulled_left` value corresponds to a single trial (i.e., `trials(1)`), which itself corresponds to the $n = 1$ portion of the statistical formula, above.

```{r b10.1}
b10.1 <-
  brm(data = d, 
      family = binomial,
      pulled_left | trials(1) ~ 1,
      prior = prior(normal(0, 10), class = Intercept),
      seed = 10,
      file = "fits/b10.01")
```

You might use `fixef()` to get a focused summary of the intercept.

```{r, message = F, warning = F}
library(tidyverse)

fixef(b10.1) %>%
  round(digits = 2)
```

The `brms::inv_logit_scaled()` function will be our alternative to the `logistic()` function in rethinking. Here we use it to convert the 89% interval estimates McElreath reported on page 294.

```{r}
c(.18, .46) %>%
  inv_logit_scaled()
```

Here we use it to convert our `fixef()` output (which contains 95% intervals).

```{r}
fixef(b10.1)[, -2] %>%
  inv_logit_scaled()
```

With the next two chimp models, we add predictors in the usual way.

```{r b10.2}
b10.2 <-
  brm(data = d, 
      family = binomial,
      pulled_left | trials(1) ~ 1 + prosoc_left,
      prior = c(prior(normal(0, 10), class = Intercept),
                prior(normal(0, 10), class = b)),
      seed = 10,
      file = "fits/b10.02")

b10.3 <-
  update(b10.2,
         newdata = d,
         formula = pulled_left | trials(1) ~ 1 + prosoc_left + condition:prosoc_left,
         seed = 10,
         file = "fits/b10.03")
```

Compute the WAIC for each model and save the results within the brmfit objects.

```{r, warning = F, message = F}
b10.1 <- add_criterion(b10.1, "waic")
b10.2 <- add_criterion(b10.2, "waic")
b10.3 <- add_criterion(b10.3, "waic")
```

Compare them with the `loo_compare()` and make sure to add the `criterion = "waic"` argument.

```{r}
w <- loo_compare(b10.1, b10.2, b10.3, criterion = "waic")

print(w, simplify = F)
```

Recall our `cbind()` trick to convert the differences from the $\text{elpd}$ metric to the WAIC metric.

```{r}
cbind(waic_diff = w[, 1] * -2,
      se        = w[, 2] *  2) %>% 
  round(digits = 2)
```

For this chapter, we'll take our color scheme from the `"Moonrise2"` palette from the [wesanderson package](https://cran.r-project.org/package=wesanderson) [@R-wesanderson].

```{r, message = F, fig.width = 3, fig.height = 1}
library(wesanderson)

wes_palette("Moonrise2")

wes_palette("Moonrise2")[1:4]
```

We'll also take a few formatting cues from Edward Tufte [-@tufteVisualDisplayQuantitative2001], courtesy of the [ggthemes package](https://cran.r-project.org/package=ggthemes). The `theme_tufte()` function will change the default font and remove some chart junk. The `theme_set()` function, below, will make these adjustments the default for all subsequent ggplot2 plots. To undo this, just execute `theme_set(theme_default())`.

```{r, message = F, warning = F}
library(ggthemes)

theme_set(
  theme_default() + 
    theme_tufte() +
    theme(plot.background = element_rect(fill  = wes_palette("Moonrise2")[3],
                                         color = wes_palette("Moonrise2")[3]))
)
```

Finally, here's our WAIC plot.

```{r, fig.width = 4.5, fig.height = 1.25}
w %>%
  data.frame() %>% 
  rownames_to_column(var = "model") %>% 
  
  ggplot() +
  geom_pointrange(aes(x = reorder(model, -waic), y = waic,
                      ymin = waic - se_waic,
                      ymax = waic + se_waic,
                      color = model),
                  shape = 16) +
  scale_color_manual(values = wes_palette("Moonrise2")[c(1:2, 4)]) +
  coord_flip() +
  labs(title = "WAIC",
       x = NULL, 
       y = NULL) +
  theme(axis.ticks.y = element_blank(),
        legend.position = "none")
```

The full model, `b10.3`, did not have the lowest WAIC value. Though note how wide those standard error bars are relative to the point estimates. There's a lot of model uncertainty there. Here are the WAIC weights.

```{r model_weights, message = F}
model_weights(b10.1, b10.2, b10.3, 
              weights = "waic")
```

Let's look at the parameter summaries for the theory-based model.

```{r}
print(b10.3)
```

Here's what the odds are multiplied by.

```{r, message = F}
fixef(b10.3)[2] %>%
  exp()
```

Given an estimated value of 4, the probability of a pull, all else equal, would be close to 1.

```{r}
inv_logit_scaled(4)
```

Adding the coefficient, `fixef(b10.3)[2]`, would yield an even higher estimate.

```{r}
(4 + fixef(b10.3)[2]) %>%
  inv_logit_scaled()
```

For our variant of Figure 10.2, we use `brms::pp_average()` in place of `rethinking::ensemble()`.

```{r, fig.height = 2.75, fig.width = 3, warning = F, message = F}
# the combined `fitted()` results of the three models weighted by their WAICs
ppa <- 
  pp_average(b10.1, b10.2, b10.3,
             weights = "waic",
             method = "fitted") %>%
  as_tibble() %>% 
  bind_cols(b10.3$data) %>% 
  distinct(Estimate, Q2.5, Q97.5, condition, prosoc_left) %>% 
  mutate(x_axis = str_c(prosoc_left, condition, sep = "/")) %>%
  mutate(x_axis = factor(x_axis, levels = c("0/0", "1/0", "0/1", "1/1"))) %>% 
  rename(pulled_left = Estimate)

# the empirically-based summaries
d_plot <-
  d %>%
  group_by(actor, condition, prosoc_left) %>%
  summarise(pulled_left = mean(pulled_left)) %>%
  mutate(x_axis = str_c(prosoc_left, condition, sep = "/")) %>%
  mutate(x_axis = factor(x_axis, levels = c("0/0", "1/0", "0/1", "1/1")))

# the plot
ppa %>% 
  ggplot(aes(x = x_axis)) +
  geom_smooth(aes(y = pulled_left, ymin = Q2.5, ymax = Q97.5, group = 0),
              stat = "identity",
              fill = wes_palette("Moonrise2")[2], color = "black", 
              alpha = 1, linewidth = 1/2) +
  geom_line(data = d_plot,
            aes(y = pulled_left, group = actor),
            color = wes_palette("Moonrise2")[1], linewidth = 1/3) +
  scale_x_discrete("prosoc_left/condition", expand = c(.03, .03)) +
  ylab("proportion pulled left") +
  coord_cartesian(ylim = 0:1) +
  theme(axis.ticks.x = element_blank())
```

McElreath didn't show the actual pairs plot in the text. Here's ours using `mcmc_pairs()`.

```{r, message = F, warning = F, fig.height = 4, fig.width = 4.5}
library(bayesplot)

# this helps us set our custom color scheme
color_scheme_set(wes_palette("Moonrise2")[c(3, 1, 2, 2, 1, 1)])

# the actual plot
mcmc_pairs(x = as_draws_df(b10.3),
           pars = vars(b_Intercept:`b_prosoc_left:condition`),
           off_diag_args = list(size = 1/10, alpha = 1/6),
           diag_fun = "dens")
```

As McElreath observed, the posterior looks multivariate Gaussian.

In equations, the next model follows the form

\begin{align*}
\text{pulled_left}_i      & \sim \operatorname{Binomial}(1, p_i) \\
\operatorname{logit}(p_i) & = \alpha_{\text{actor}} + (\beta_1 + \beta_2 \text{condition}_i) \text{prosoc_left}_i \\
\alpha_{\text{actor}}     & \sim \operatorname{Normal}(0, 10) \\
\beta_1                   & \sim \operatorname{Normal}(0, 10) \\
\beta_2                   & \sim \operatorname{Normal}(0, 10).
\end{align*}

Enclosing the `actor` variable within `factor()` will produce the indexing we need to get `actor`-specific intercepts. Also notice we're using the `0 + factor(actor)` part of the model `formula` to suppress the brms default intercept. As such, the priors for all parameters in the model will be of `class = b`. And since we're using the same Gaussian prior for each, we only need one line for the `prior` argument.

```{r b10.4}
b10.4 <-
  brm(data = d, family = binomial,
      pulled_left | trials(1) ~ 0 + factor(actor) + prosoc_left + condition:prosoc_left ,
      prior(normal(0, 10), class = b),
      iter = 2500, warmup = 500, chains = 2, cores = 2,
      control = list(adapt_delta = 0.9),
      seed = 10,
      file = "fits/b10.04")
```

Within the tidyverse, the `distinct()` function returns the information you'd otherwise get from `unique()`.

```{r}
d %>%
  distinct(actor)
```

With a single-level model like this, we have no need to use something like `depth=2` for our posterior summary.

```{r}
print(b10.4)
```

Correspondingly, `brms::as_draws_df()` returns an object for `b10.4` that doesn't quite follow the same structure as from `rethinking::extract.samples()`.

```{r}
post <- as_draws_df(b10.4)
 
post %>%
  glimpse()
```

Here's our variant of Figure 10.3, the $\alpha$ density for `actor == 2`.

```{r, fig.height = 2.75, fig.width = 3}
post %>%
  ggplot(aes(x = b_factoractor2)) +
  geom_density(color = "transparent",
               fill = wes_palette("Moonrise2")[1]) +
  scale_x_continuous(NULL, limits = c(0, NA)) +
  scale_y_continuous(NULL, breaks = NULL) +
  labs(title = "Actor 2's large and uncertain intercept",
       subtitle = "Once your log-odds are above, like, 4, it's all\npretty much a probability of 1.")
```

Figure 10.4. shows the idiographic trajectories for four of our chimps.

```{r, fig.height = 4, fig.width = 6, warning = F, message = F}
# subset the `d_plot` data
d_plot_4 <-
  d_plot %>%
  filter(actor %in% c(3, 5:7)) %>%
  ungroup() %>% 
  mutate(actor = str_c("actor ", actor))

# compute the model-implied estimates with `fitted()` and wrangle
f <-
  fitted(b10.4) %>% 
  as_tibble() %>% 
  bind_cols(b10.4$data) %>% 
  filter(actor %in% c(3, 5:7)) %>% 
  distinct(Estimate, Q2.5, Q97.5, condition, prosoc_left, actor) %>% 
  select(actor, everything()) %>% 
  mutate(actor  = str_c("actor ", actor),
         x_axis = str_c(prosoc_left, condition, sep = "/")) %>%
  mutate(x_axis = factor(x_axis, levels = c("0/0", "1/0", "0/1", "1/1"))) %>% 
  rename(pulled_left = Estimate)

# plot
f %>% 
  ggplot(aes(x = x_axis, y = pulled_left, group = actor)) +
  geom_smooth(aes(ymin = Q2.5, ymax = Q97.5),
              stat = "identity",
              fill = wes_palette("Moonrise2")[2], color = "black", 
              alpha = 1, linewidth = 1/2) +
  geom_line(data = d_plot_4,
            color = wes_palette("Moonrise2")[1], linewidth = 1.25) +
  scale_x_discrete("prosoc_left/condition", expand = c(.03, .03)) +
  scale_y_continuous("proportion pulled left",
                     breaks = c(0, .5, 1), limits = c(0, 1)) +
  theme(axis.ticks.x = element_blank(),
        panel.background = element_rect(fill = alpha("white", .075), 
                                        color = "transparent")) +
  facet_wrap(~actor)
```

McElreath mused: "There are a number of loose ends with this analysis. Does model [`b10.4`], with its 6 additional parameters, still look good after estimating overfitting with WAIC?" (p. 302). We won't be following along with the practice problems at the end of the chapter, but we may as well just check the WAIC real quick.

```{r, warning = F, message = F}
b10.4 <- add_criterion(b10.4, "waic")

loo_compare(b10.1, b10.2, b10.3, b10.4, criterion = "waic") %>% 
  print(simplify = F)
```

Here are the updated WAIC weights.

```{r}
model_weights(b10.1, b10.2, b10.3, b10.4, weights = "waic") %>% 
  round(digits = 2)
```

Both the WAIC differences and the WAIC weights suggest our 9-parameter `b10.4` was substantially better than the previous models, even after correcting for overfitting. Some times group averages aren't good enough. When you have data with many occasions within cases, fitting models that allow for individual differences is generally the way to go.

#### Overthinking: Using the ~~by~~ `group_by()` function.

Instead of focusing on base R, let's work within the tidyverse. If you wanted to compute the proportion of trials `pulled_left == 1` for each combination of `prosoc_left`, `condition`, and chimp `actor`, you'd put those last three variables within `group_by()` and then compute the `mean()` of `pulled_left` within `summarise()`.

```{r, message = F}
d %>% 
  group_by(prosoc_left, condition, actor) %>% 
  summarise(`proportion pulled_left` = mean(pulled_left))
```

And since we're working within the tidyverse, that operation returns a tibble rather than a list.

### Aggregated binomial: Chimpanzees again, condensed.

With the tidyverse, we use `group_by()` and `summarise()` to achieve what McElreath did with `aggregate()`.

```{r, message = F}
d_aggregated <-
  d %>%
  select(-recipient, -block, -trial, -chose_prosoc) %>%
  group_by(actor, condition, prosoc_left) %>%
  summarise(x = sum(pulled_left))

d_aggregated %>%
  filter(actor %in% c(1, 2))
```

To fit an aggregated binomial model in brms, we augment the `<criterion> | trials()` syntax where the value that goes in `trials()` is either a fixed number, as in this case, or variable in the data indexing $n$. Either way, at least some of those trials will have an $n > 1$. Here we'll use the hard-code method, just like McElreath did in the text.

```{r b10.5}
b10.5 <-
  brm(data = d_aggregated, 
      family = binomial,
      x | trials(18) ~ 1 + prosoc_left + condition:prosoc_left,
      prior = c(prior(normal(0, 10), class = Intercept),
                prior(normal(0, 10), class = b)),
      iter = 2500, warmup = 500, cores = 2, chains = 2, 
      seed = 10,
      file = "fits/b10.05")
```

We might compare `b10.3` with `b10.5` like this.

```{r}
fixef(b10.3) %>% round(digits = 2)
fixef(b10.5) %>% round(digits = 2)
```

A coefficient plot can offer a complimentary perspective.

```{r, fig.width = 4.5, fig.height = 2.5, warning = F, message = F}
# wrangle
bind_rows(
  fixef(b10.3) %>% 
    data.frame() %>% 
    rownames_to_column("term"),
  fixef(b10.5) %>%
    data.frame() %>% 
    rownames_to_column("term")
) %>% 
  mutate(fit = rep(c("b10.3", "b10.5"), each = n() / 2)) %>% 
  
  # plot
  ggplot() +
  geom_pointrange(aes(x = fit, y = Estimate,
                      ymin = Q2.5, ymax = Q97.5,
                      color = term),
                  shape = 16) +
  scale_color_manual(values = wes_palette("Moonrise2")[c(1:2, 4)]) +
  labs(x = NULL, y = NULL) +
  coord_flip() +
  theme(axis.ticks.y = element_blank(),
        legend.position = "none") +
  facet_wrap(~term, ncol = 1)
```

The two are close within simulation error.

### Aggregated binomial: Graduate school admissions.

Load the infamous `UCBadmit` data [see @bickelSexBiasGraduate1975].

```{r, message = F, warning = F}
# detach(package:brms)
library(rethinking)
data(UCBadmit)
d <- UCBadmit
```

Switch from rethinking to brms.

```{r, message = F, warning = F}
detach(package:rethinking, unload = T)
library(brms)
rm(UCBadmit)

d
```

Now compute our newly-constructed dummy variable, `male`.

```{r}
d <- 
  d %>%
  mutate(male = ifelse(applicant.gender == "male", 1, 0))
```

The univariable logistic model with `male` as the sole predictor of `admit` follows the form

\begin{align*}
n_{\text{admit}_i}        & \sim \operatorname{Binomial}(n_i, p_i) \\
\operatorname{logit}(p_i) & = \alpha + \beta \text{male}_i \\
\alpha                    & \sim \operatorname{Normal}(0, 10) \\
\beta                     & \sim \operatorname{Normal}(0, 10).
\end{align*}

The second model omits the `male` predictor.

```{r b10.6}
b10.6 <-
  brm(data = d, 
      family = binomial,
      admit | trials(applications) ~ 1 + male ,
      prior = c(prior(normal(0, 10), class = Intercept),
                prior(normal(0, 10), class = b)),
      iter = 2500, warmup = 500, cores = 2, chains = 2,
      seed = 10,
      # this line isn't usually necessary,
      # but it will help with our `loo_moment_match()` code below
      save_pars = save_pars(all = T),
      file = "fits/b10.06") 

b10.7 <-
  brm(data = d, 
      family = binomial,
      admit | trials(applications) ~ 1,
      prior(normal(0, 10), class = Intercept),
      iter = 2500, warmup = 500, cores = 2, chains = 2,
      seed = 10,
      save_pars = save_pars(all = T),
      file = "fits/b10.07")
```

Compute the information criteria for each model and save the results within the brmfit objects.

```{r, message = F}
b10.6 <- add_criterion(b10.6, "waic")
b10.7 <- add_criterion(b10.7, "waic")
```

Here's the WAIC comparison.

```{r}
w <- loo_compare(b10.6, b10.7, criterion = "waic")

print(w, simplify = F)
```

If you prefer the difference in the WAIC metric, use our `cbind()` conversion method from above. Here are the WAIC weights.

```{r}
model_weights(b10.6, b10.7, weights = "waic") %>% 
  round(digits = 2)
```

**Bonus: Information criteria digression.**

Let's see what happens if we switch to the LOO.

```{r}
b10.6 <- add_criterion(b10.6, "loo")
b10.7 <- add_criterion(b10.7, "loo")
```

If you just ape the text and use the WAIC, everything appears fine. But holy smokes look at those nasty warning messages from the `loo()`! One of the frightening but ultimately handy things about working with the PSIS-LOO is that it requires we estimate a Pareto $k$ parameter, which you can learn all about in the `loo-package` section of the [loo reference manual](https://cran.r-project.org/package=loo/loo.pdf) [@loo2022RM]. As it turns out, the Pareto $k$ [can be used as a diagnostic tool](https://cran.r-project.org/package=loo/vignettes/loo2-example.html#plotting-pareto-k-diagnostics) [@vehtariUsingLooPackage2022]. Each case in the data gets its own $k$ value and we like it when those $k$'s are low. The makers of the loo package get worried when those $k$'s exceed 0.7 and as a result, `loo()` spits out a warning message when they do.

First things first, if you explicitly open the loo package, you'll have access to some handy diagnostic functions.

```{r, message = F, warning = F}
library(loo)
```

We'll be leveraging those $k$ values with the `pareto_k_table()` and `pareto_k_ids()` functions. Both functions take objects created by the `loo()` or `psis()` functions. So, before we can get busy, we'll first make two objects with the `loo()`.

```{r}
l_b10.6 <- loo(b10.6)
l_b10.7 <- loo(b10.7)
```

There are those warning messages, again. Using the loo-object for model `b10.6`, which we've named `l_b10.6`, let's take a look at the `pareto_k_table()` function.

```{r}
pareto_k_table(l_b10.6)
```

You may have noticed that this same table pops out when you just do something like `loo(b10.6)`. Recall that this data set has 12 observations (i.e., execute `count(d)`). With `pareto_k_table()`, we see how the Pareto $k$ values have been categorized into bins ranging from "good" to "very bad". Clearly, we like low $k$'s. In this example, our observations are all over the place, with `r pareto_k_ids(l_b10.6, threshold = 0.7) %>% length()` in the "bad" to "very bad" $k$ ranges. We can take a closer look like this:

```{r, fig.width = 4.5, fig.height = 3.5}
plot(l_b10.6)
```

So when you `plot()` a loo object, you get a nice diagnostic plot for those $k$ values, ordered by observation number. Our plot indicates cases 1, 2, 3, 11, and 12 had "very bad" $k$ values for this model. If we wanted to further verify to ourselves which observations those were, we'd use the `pareto_k_ids()` function.

```{r}
pareto_k_ids(l_b10.6, threshold = 1)
```

Note our use of the `threshold` argument. Play around with different values to see how it works. If you want an explicit look at those $k$ values, you execute something like this.

```{r}
l_b10.6$diagnostics
```

The `pareto_k` values can be used to examine cases that are overly-influential on the model parameters, something like a Cook's $D_{i}$. See, for example [this discussion on stackoverflow.com](https://stackoverflow.com/questions/39578834/linear-model-diagnostics-for-bayesian-models-using-rstan/39595436) in which several members of the [Stan team](https://mc-stan.org/) weighed in. The issue is also discussed in @vehtariPracticalBayesianModel2017 and in [this presentation by Aki Vehtari](https://youtu.be/FUROJM3u5HQ).

Anyway, the implication of all this is these values suggest model `b10.6` isn't a great fit for these data.

Part of the warning message for model `b10.6` read:

> It is recommended to set 'moment_match = TRUE' in order to perform moment matching for problematic observations.

Let's do that using the `brms::loo_moment_match()` function.

```{r l_b10.6_mm, warning = F, message = F, results = 'hide'}
l_b10.6_mm <- loo_moment_match(b10.6, loo = l_b10.6)
```

Check the results.

```{r}
l_b10.6_mm
```

Now that looks better. We'll do the same thing for model `b10.7`. 

```{r l_b10.7_mm, warning = F, message = F, results = 'hide'}
l_b10.7_mm <- loo_moment_match(b10.7, loo = l_b10.7)
```

Okay, let's compare models with formal $\text{elpd}_\text{loo}$ differences before and after adjusting with the moment match approach.

```{r}
loo_compare(l_b10.6, l_b10.7)
loo_compare(l_b10.6_mm, l_b10.7_mm)
```

In this case, the results are similar. The standard errors for the differences are huge compared to the point estimates, suggesting large uncertainty. Watch out for this in your real-world data analyses, though.

But this has all been a tangent from the central thrust of this section.

**Back from our information criteria digression.**

Let's get back on track with the text. Here's a look at `b10.6`, the unavailable model.

```{r}
print(b10.6)
```

Here's the relative difference in admission odds.

```{r, warning = F, message = F}
fixef(b10.6)[2] %>%
  exp() %>%
  round(digits = 2)
```

And now we'll compute difference in admission probabilities.

```{r}
post <- as_draws_df(b10.6)

post %>%
  mutate(p_admit_male   = inv_logit_scaled(b_Intercept + b_male),
         p_admit_female = inv_logit_scaled(b_Intercept)) %>% 
  mutate(diff_admit = p_admit_male - p_admit_female) %>%
  summarise(`2.5%`  = quantile(diff_admit, probs = .025),
            `50%`   = median(diff_admit),
            `97.5%` = quantile(diff_admit, probs = .975))
```

Instead of the `summarise()` code, we could have also used `tidybayes::median_qi(diff_admit)`. It's good to have options. Here's our version of Figure 10.5.

```{r, fig.height = 2.5, fig.width = 4, message = F}
d <-
  d %>%
  mutate(case = factor(1:12))

p <- 
  predict(b10.6) %>% 
  as_tibble() %>% 
  bind_cols(d)

text <-
  d %>%
  group_by(dept) %>%
  summarise(case  = mean(as.numeric(case)),
            admit = mean(admit / applications) + .05)

ggplot(data = d, aes(x = case, y = admit / applications)) +
  geom_pointrange(data = p, 
                  aes(y    = Estimate / applications,
                      ymin = Q2.5     / applications ,
                      ymax = Q97.5    / applications),
                  color = wes_palette("Moonrise2")[1],
                  shape = 1, alpha = 1/3) +
  geom_point(color = wes_palette("Moonrise2")[2]) +
  geom_line(aes(group = dept),
            color = wes_palette("Moonrise2")[2]) +
  geom_text(data = text,
            aes(y = admit, label = dept),
            color = wes_palette("Moonrise2")[2],
            family = "serif") +
  labs(title = "Posterior validation check",
       y = "Proportion admitted") +
  coord_cartesian(ylim = c(0, 1)) +
  theme(axis.ticks.x = element_blank())
```

As alluded to in all that LOO/`pareto_k` talk, above, this is not a great fit. So we'll ditch the last model paradigm for one that answers the new question "*What is the average difference in probability of admission between females and males within departments?*" (p. 307). The statistical formula for the full model follows the form

\begin{align*}
n_{\text{admit}_i}        & \sim \operatorname{Binomial}(n_i, p_i) \\
\operatorname{logit}(p_i) & = \alpha_{\text{dept}_i} + \beta \text{male}_i \\
\alpha_{\text{dept}}      & \sim \operatorname{Normal}(0, 10) \\
\beta                     & \sim \operatorname{Normal}(0, 10).
\end{align*}

We don't need to coerce an index like McElreath did in the text. But here are the models.

```{r b10.8}
b10.8 <-
  brm(data = d, 
      family = binomial,
      admit | trials(applications) ~ 0 + dept,
      prior = prior(normal(0, 10), class = b),
      iter = 2500, warmup = 500, cores = 2, chains = 2,
      seed = 10,
      file = "fits/b10.08") 

b10.9 <-
  update(b10.8,
         newdata = d,
         formula = admit | trials(applications) ~ 0 + dept + male,
         seed = 10,
         file = "fits/b10.09")
```

Let's make two more `loo()` objects, this time using the `reloo = TRUE` approach.

```{r reloo_b10.8_and_b10.9, message = F, warning = F, results = 'hide'}
l_b10.8_reloo <- loo(b10.8, reloo = T)
l_b10.9_reloo <- loo(b10.9, reloo = T)
```

Now compare them.

```{r}
loo_compare(l_b10.6_mm, l_b10.7_mm, l_b10.8_reloo, l_b10.9_reloo)
```

Here are the LOO weights.

```{r}
model_weights(b10.6, b10.7, b10.8, b10.9,
              weights = "loo") %>% 
  round(digits = 3)
```

The parameters summaries for our multivariable model, `b10.9`, look like this.

```{r}
fixef(b10.9) %>% round(digits = 2)
```

And on the proportional odds scale, the posterior mean for `b_male` is:

```{r}
fixef(b10.9)[7, 1] %>% exp()
```

Since we've been using brms, there's no need to fit our version of McElreath's `m10.9stan`. We already have that in our `b10.9`. But just for kicks and giggles, here's another way to get the model summary.

```{r}
b10.9$fit
```

Here's our version of Figure 10.6, the posterior validation check.

```{r, fig.height = 2.5, fig.width = 4}
predict(b10.9) %>%
  as_tibble() %>% 
  bind_cols(d) %>% 

  ggplot(aes(x = case, y = admit / applications)) +
  geom_pointrange(aes(y    = Estimate / applications,
                      ymin = Q2.5     / applications ,
                      ymax = Q97.5    / applications),
                  color = wes_palette("Moonrise2")[1],
                  shape = 1, alpha = 1/3) +
  geom_point(color = wes_palette("Moonrise2")[2]) +
  geom_line(aes(group = dept),
            color = wes_palette("Moonrise2")[2]) +
  geom_text(data = text,
            aes(y = admit, label = dept),
            color = wes_palette("Moonrise2")[2],
            family = "serif") +
  labs(title = "Posterior validation check",
       y = "Proportion admitted") +
  coord_cartesian(ylim = c(0, 1)) +
  theme(axis.ticks.x = element_blank())
```

The model predictions are imperfect, but way more valid than before. The posterior looks reasonably multivariate Gaussian.

```{r, message = F, warning = F, fig.height = 7, fig.width = 7.5}
pairs(b10.9,
      off_diag_args = list(size = 1/10, alpha = 1/6))
```

#### Rethinking: Simpson's paradox is not a paradox.

> This empirical example is a famous one in statistical teaching. It is often used to illustrate a phenomenon known as **Simpson's paradox**. Like most paradoxes, there is no violation of logic, just of intuition. And since different people have different intuition, Simpson's paradox means different things to different people. The poor intuition being violated in this case is that a positive association in the entire population should also hold within each department. (p. 309, **emphasis** in the original)

In my field of clinical psychology, Simpson's paradox is an important, if under-appreciated, phenomenon. If you're in the social sciences as well, I highly recommend spending more time thinking about it. To get you started, I blogged about it [here](https://solomonkurz.netlify.app/blog/2019-10-09-individuals-are-not-small-groups-i-simpson-s-paradox/) and @kievitSimpsonParadoxPsychological2013 wrote a great tutorial paper called [*Simpson's paradox in psychological science: a practical guide*](https://www.frontiersin.org/articles/10.3389/fpsyg.2013.00513/full).

#### Overthinking: WAIC and aggregated binomial models.

McElreath wrote:

> The `WAIC` function in `rethinking` detects aggregated binomial models and automatically splits them apart into 0/1 Bernoulli trials, for the purpose of calculating WAIC. It does this, because WAIC is computed point by point (see [Chapter 6][Overthinking: WAIC calculation.]). So what you define as a "point" affects WAIC's value. In an aggregated binomial each "point" is a bunch of independent trials that happen to share the same predictor values. In order for the disaggregated and aggregated models to agree, it makes sense to use the disaggregated representation. (p. 309)

To my knowledge, `brms::waic()` and `brms::loo()` do not do this, which might well be why some of our values didn't match up with those in the text. If you have additional insight on this, please [share with the rest of the class](https://github.com/ASKurz/Statistical_Rethinking_with_brms_ggplot2_and_the_tidyverse/issues).

### Fitting binomial regressions with `glm()`.

We're not here to learn frequentist code, so we're going to skip most of this section. But model `m.good` is worth fitting. Here are the data.

```{r}
# outcome and predictor almost perfectly associated
y <- c(rep(0, 10), rep(1, 10))
x <- c(rep(-1, 9), rep(1, 11))
```

We are going to depart from McElreath's naming convention in the text and call this fit `b10.good`. It'll make it easier to find in this project's [`fits` folder](https://github.com/ASKurz/Statistical_Rethinking_with_brms_ggplot2_and_the_tidyverse/tree/master/fits).

```{r b10.good}
b10.good <-
  brm(data = list(y = y, x = x), 
      family = binomial,
      y | trials(1) ~ 1 + x,
      prior = c(prior(normal(0, 10), class = Intercept),
                prior(normal(0, 10), class = b)),
      seed = 10,
      file = "fits/b10.good") 
```

Our model summary will differ a bit from the one in the text. It seems this is because of the MAP/HMC contrast and our choice of priors.

```{r}
print(b10.good)
```

You might experiment with different prior $\textit{SD}$'s to see how they influence the posterior $\textit{SD}$'s. Anyways, here's the `pairs()` plot McElreath excluded from the text.

```{r, fig.width = 3.25, fig.height = 3}
pairs(b10.good,
      off_diag_args = list(size = 1/10, alpha = 1/6))
```

That posterior, my friends, is not multivariate Gaussian. The plot deserves an extensive quote from McElreath.

> Inspecting the pairs plot (~~not~~ shown) demonstrates just how subtle even simple models can be, once we start working with GLMs. I don't say this to scare the reader. But it's true that even simple models can behave in complicated ways. *How you fit the model is part of the model, and in principle no GLM is safe for MAP estimation*. (p. 311, *emphasis* added)

## Poisson regression

> When a binomial distribution has a very small probability of an event $p$ and a very large number of trials $n$, then it takes on a special shape. The expected value of a binomial distribution is just $np$, and its variance is $np(1 - p)$. But when $n$ is very large and $p$ is very small, then these are approximately the same. (p. 311)

Data of this kind are often called count data. Here we simulate some.

```{r}
set.seed(10) # make the results reproducible

tibble(y = rbinom(1e5, 1000, 1/1000)) %>% 
  summarise(y_mean     = mean(y),
            y_variance = var(y))
```

Yes, those statistics are virtually the same. When dealing with Poisson data, $\mu = \sigma^2$. When you have a number of trials for which $n$ is unknown or much larger than seen in the data, the Poisson likelihood is a useful tool. We define it as

$$y \sim \operatorname{Poisson}(\lambda).$$

As $\lambda$ expresses both mean and variance because, within this model, the variance scales right along with the mean. Since $\lambda$ is constrained to be positive, we typically use the log link. Thus the basic Poisson regression model is

\begin{align*}
y_i              & \sim \operatorname{Poisson}(\lambda_i) \\
\log (\lambda_i) & = \alpha + \beta x_i,
\end{align*}

where all model parameters receive priors following the forms we've been practicing. We read further:

> The parameter $\lambda$ is the expected value, but it's also commonly thought of as a rate. Both interpretations are correct, and realizing this allows to make Poisson models for which the exposure varies across cases $i$...
>
> Implicitly, $\lambda$ is equal to an expected number of events, $\mu$, per unit of time or distance, $\tau$. This implies that $\lambda = \mu/\tau$, which lets us redefine the link:
>
> \begin{align*}
> y_i            & \sim \operatorname{Poisson}(\lambda_i) \\
> \log \lambda_i & = \log \frac{\mu_i}{\tau_i} = \alpha + \beta x_i
> \end{align*}
>
> Since the logarithm of a ratio is the same as a difference of logarithms, we can also write:
>
> $$\log \lambda_i = \log \mu_i - \log \tau_i = \alpha + \beta x_i$$
>
> These $\tau$ values are the "exposures." So if different observations $i$ have different exposures, this implies that the expected value on row $i$ is given by:
>
> $$\log \mu_i = \log \tau_i + \alpha + \beta x_i$$
>
> When $\tau_i = 1$, then $\log \tau_i = 0$ and we're back where we started. But when the exposure varies across cases, then $\tau_i$ does the important work of correctly scaling the expected number of events for each case $i$. (pp. 312--313)

### Example: Oceanic tool complexity.

Load the `Kline` data [see @klinePopulationSizePredicts2010].

```{r, message = F, warning = F}
library(rethinking)
data(Kline)
d <- Kline
```

Switch from rethinking to brms.

```{r, message = F, warning = F}
detach(package:rethinking, unload = T)
library(brms)
rm(Kline)

d
```

Here are our new columns.

```{r}
d <-
  d %>%
  mutate(log_pop      = log(population),
         contact_high = ifelse(contact == "high", 1, 0))
```

Our statistical model will follow the form

\begin{align*}
\text{total_tools}_i & \sim \operatorname{Poisson}(\lambda_i) \\
\log (\lambda_i)     & = \alpha + \beta_1 \text{log_pop}_i + \beta_2 \text{contact_high}_i + \beta_3 \text{contact_high}_i \times \text{log_pop}_i \\
\alpha  & \sim \operatorname{Normal}(0, 100) \\
\beta_1 & \sim \operatorname{Normal}(0, 1) \\
\beta_2 & \sim \operatorname{Normal}(0, 1) \\
\beta_3 & \sim \operatorname{Normal}(0, 1).
\end{align*}

The only new thing in our model code is `family = poisson`. brms defaults to the `log()` link.

```{r b10.10}
b10.10 <-
  brm(data = d, 
      family = poisson,
      total_tools ~ 1 + log_pop + contact_high + contact_high:log_pop,
      prior = c(prior(normal(0, 100), class = Intercept),
                prior(normal(0, 1), class = b)),
      iter = 3000, warmup = 1000, chains = 4, cores = 4,
      seed = 10,
      file = "fits/b10.10") 
```

```{r}
print(b10.10)
```

We can use `vcov()` to extract the correlation matrix for the parameters.

```{r}
vcov(b10.10, cor = T) %>% 
  round(digits = 2)
```

And here's the coefficient plot via `bayesplot::mcmc_intervals()`.

```{r, fig.width = 7, fig.height = 1.25}
post <- as_draws_df(b10.10)

# we'll set a renewed color theme
color_scheme_set(wes_palette("Moonrise2")[c(2, 1, 4, 2, 1, 1)])

post %>%
  rename(b_interaction = `b_log_pop:contact_high`) %>%

  mcmc_intervals(pars = vars(starts_with("b_")),
                 prob = .5, 
                 prob_outer = .95) +
  theme(axis.text.y = element_text(hjust = 0),
        axis.ticks.y = element_blank())
```

How plausible is it a high-contact island will have more tools than a low-contact island?

```{r}
post <-
  post %>%
  mutate(lambda_high = exp(b_Intercept + b_contact_high + (b_log_pop + `b_log_pop:contact_high`) * 8),
         lambda_low  = exp(b_Intercept + b_log_pop * 8)) %>% 
  mutate(diff = lambda_high - lambda_low) 

post %>%
  summarise(sum = sum(diff > 0) / length(diff))
```

Quite, it turns out. Behold the corresponding Figure 10.8.a.

```{r, fig.width = 3, fig.height = 2.9}
post %>%
  ggplot(aes(x = diff)) +
  geom_density(color = "transparent",
               fill = wes_palette("Moonrise2")[1]) +
  geom_vline(xintercept = 0, linetype = 2,
             color = wes_palette("Moonrise2")[2]) +
  scale_y_continuous(NULL, breaks = NULL) +
  xlab("lambda_high - lambda_low")
```

I'm not happy with how clunky this solution is, but one way to get those marginal dot and line plots for the axes is to make intermediary tibbles. Anyway, here's a version of Figure 10.8.b.

```{r, fig.width = 3, fig.height = 2.9}
# intermediary tibbles for our the dot and line portoin of the plot
point_tibble <-
  tibble(x = c(median(post$b_contact_high), min(post$b_contact_high)),
         
         y = c(min(post$`b_log_pop:contact_high`), median(post$`b_log_pop:contact_high`)))

line_tibble <-
  tibble(parameter = rep(c("b_contact_high", "b_log_pop:contact_high"), each = 2),
         
         x = c(quantile(post$b_contact_high, probs = c(.025, .975)),
               rep(min(post$b_contact_high), times = 2)),
         
         y = c(rep(min(post$`b_log_pop:contact_high`), times = 2),
               quantile(post$`b_log_pop:contact_high`, probs = c(.025, .975))))

# the plot
post %>% 
  ggplot(aes(x = b_contact_high, y = `b_log_pop:contact_high`)) +
  geom_point(color = wes_palette("Moonrise2")[1],
             size = 1/10, alpha = 1/10) +
  geom_point(data = point_tibble,
             aes(x = x, y = y)) +
  geom_line(data = line_tibble,
            aes(x = x, y = y, group = parameter))
```

The `ggMarginal()` function from the [ggExtra package](https://CRAN.R-project.org/package=ggExtra) [@R-ggExtra] offers an interesting alternative.

```{r, fig.width = 3.5, fig.height = 3.4}
library(ggExtra)

# the base plot
p <-
  post %>% 
  ggplot(aes(x = b_contact_high, y = `b_log_pop:contact_high`)) +
  geom_point(color = wes_palette("Moonrise2")[1],
             size = 1/10, alpha = 1/10)

# add the marginal plots
p %>% 
  ggMarginal(data = post,
             type = 'density', 
             color = "transparent",
             fill = wes_palette("Moonrise2")[1], size = 4)
```

To get a feel for what's possible with `ggMarginal()`, check out [Dean Attali](https://deanattali.com/)'s [great shiny app](https://daattali.com/shiny/ggExtra-ggMarginal-demo/).

Here we deconstruct model `b10.10`, bit by bit.

```{r b10.11, warning = F, message = F}
# no interaction
b10.11 <- 
  update(b10.10, formula = total_tools ~ 1 + log_pop + contact_high,
         seed = 10,
         file = "fits/b10.11")

# no contact rate
b10.12 <-
  update(b10.10, formula = total_tools ~ 1 + log_pop,
         seed = 10,
         file = "fits/b10.12")

# no log-population
b10.13 <-
  update(b10.10, formula = total_tools ~ 1 + contact_high,
         seed = 10,
         file = "fits/b10.13")

# intercept only
b10.14 <-
  update(b10.10, formula = total_tools ~ 1,
         seed = 10,
         file = "fits/b10.14")
```

I know we got all excited with the LOO, above. Let's just be lazy and go WAIC. [Though beware, the LOO opens up a similar can of worms, here.]

```{r, message = F}
b10.10 <- add_criterion(b10.10, criterion = "waic")
b10.11 <- add_criterion(b10.11, criterion = "waic")
b10.12 <- add_criterion(b10.12, criterion = "waic")
b10.13 <- add_criterion(b10.13, criterion = "waic")
b10.14 <- add_criterion(b10.14, criterion = "waic")
```

Now compare them.

```{r}
w <- loo_compare(b10.10, b10.11, b10.12, b10.13, b10.14, criterion = "waic")

cbind(waic_diff = w[, 1] * -2,
      se        = w[, 2] *  2) %>% 
  round(digits = 2)
```

Let's get those WAIC weights, too.

```{r}
model_weights(b10.10, b10.11, b10.12, b10.13, b10.14, weights = "waic") %>% 
  round(digits = 2)
```

Now wrangle `w` a little and make the WAIC plot.

```{r, fig.width = 4.5, fig.height = 1.25}
w %>% 
  data.frame() %>% 
  rownames_to_column(var = "model") %>%
  
  ggplot(aes(x = waic,
             xmin = waic - se_waic,
             xmax = waic + se_waic,
             y = reorder(model, -waic), 
             color = model)) +
  geom_pointrange(shape = 16, show.legend = F) +
  scale_color_manual(values = wes_palette("Moonrise2")[c(1, 2, 1, 1, 1)]) +
  labs(title = "WAIC",
       x = NULL,
       y = NULL) +
  theme(axis.ticks.y = element_blank())
```

Here's our version of Figure 10.9. Recall, to do an "ensemble" posterior prediction in brms, one uses the `pp_average()` function. I know we were just lazy and focused on the WAIC. But let's play around, a bit. Here we'll weight the models based on the LOO by adding a `weights = "loo"` argument to the `pp_average()` function. If you check the corresponding section of the [brms reference manual](https://cran.r-project.org/package=brms/brms.pdf) [@brms2022RM], you'll find several weighting schemes.

```{r, fig.width = 3.5, fig.height = 3.5}
nd <-
  crossing(contact_high = 0:1,
           log_pop      = seq(from = 6.5, to = 13, length.out = 50))

ppa <- 
  pp_average(b10.10, b10.11, b10.12,
             weights = "loo",
             method  = "fitted",
             newdata = nd) %>%
  as_tibble() %>%
  bind_cols(nd)

ppa %>%
  ggplot(aes(x = log_pop, group = contact_high, color = contact_high)) +
  geom_smooth(aes(y = Estimate, ymin = Q2.5, ymax = Q97.5, fill = contact_high),
              stat = "identity",
              alpha = 1/4, linewidth = 1/2) +
  geom_text(data = d, 
            aes(y = total_tools, label = total_tools),
            size = 3.5) +
  labs(subtitle = "Blue is the high contact rate; black is the low.",
       x = "log population",
       y = "total tools") +
  coord_cartesian(xlim = c(7.1, 12.4),
                  ylim = c(12, 70)) +
  theme(legend.position = "none",
        panel.border = element_blank())
```

In case you were curious, here are those LOO weights.

```{r}
model_weights(b10.10, b10.11, b10.12, 
              weights = "loo")
```

### MCMC islands.

We fit our analogue to `m10.10stan`, `b10.10`, some time ago. 

```{r}
print(b10.10)
```

Center `log_pop`.

```{r}
d <-
  d %>%
  mutate(log_pop_c = log_pop - mean(log_pop))
```

Now fit the `log_pop`-centered model.

```{r b10.10_c}
b10.10_c <-
  brm(data = d, 
      family = poisson,
      total_tools ~ 1 + log_pop_c + contact_high + contact_high:log_pop_c,
      prior = c(prior(normal(0, 10), class = Intercept),
                prior(normal(0, 1), class = b)),
      iter = 3000, warmup = 1000, chains = 4, cores = 4,
      seed = 10,
      file = "fits/b10.10_c")
```

```{r}
print(b10.10_c)
```

We've been using `bayesplot::mcmc_pairs()` a lot for our posterior pairs plots. Let's get in a little practice with `GGally::ggpairs()` for Figure 10.10. In Chapters [5][Multicollinear `milk`.] and [8][Visualization.], we used custom functions to augment the default `ggpairs()` output. We'll continue that trend, here. Here are the custom functions for the upper triangle, the diagonal, and the lower triangle.

```{r}
my_upper <- function(data, mapping, ...) {
  
  # get the x and y data to use the other code
  x <- eval_data_col(data, mapping$x)
  y <- eval_data_col(data, mapping$y)
  
  r  <- unname(cor.test(x, y)$estimate)
  rl <- formatC(r, format = 'f', digits = 2)
  
  # plot the cor value
  ggally_text(
    label = rl, 
    mapping = aes(),
    size = 4,
    color = wes_palette("Moonrise2")[4], 
    alpha = 4/5,
    family = "Times") +
    theme_void()
}

my_diag <- function(data, mapping, ...) {
  ggplot(data = data, mapping = mapping) + 
    geom_density(fill = wes_palette("Moonrise2")[2], linewidth = 0) +
    theme_void()
}

my_lower <- function(data, mapping, ...) {
  ggplot(data = data, mapping = mapping) + 
    geom_point(color = wes_palette("Moonrise2")[1], 
               size = 1/10, alpha = 1/10) +
    theme_void()
}
```

To learn more about the nature of the code for the `my_upper()` function, check out [issue #139](https://github.com/ggobi/ggally/issues/139) in the [GGally GitHub repository](https://github.com/ggobi/ggally). Here are our plots for the left and right panels of Figure 10.10.

```{r, fig.height = 3.5, fig.width = 4, warning = F, message = F}
library(GGally)

# left panel for `b10.10`
as_draws_df(b10.10) %>% 
  select(starts_with("b_")) %>% 
  set_names(c("alpha", "beta[log_pop]", "beta[contact_high]", "beta[interaction]")) %>%
  ggpairs(upper = list(continuous = my_upper),
          diag = list(continuous = my_diag),
          lower = list(continuous = my_lower),
          labeller = "label_parsed") +
  ggtitle("Model: b10.10") +
  theme(strip.text = element_text(size = 11))

# right panel for `b10.10_c`
as_draws_df(b10.10_c) %>% 
  select(starts_with("b_")) %>% 
  set_names(c("alpha", "beta[log_pop_c]", "beta[contact_high]", "beta[interaction]")) %>%
  ggpairs(upper = list(continuous = my_upper),
          diag = list(continuous = my_diag),
          lower = list(continuous = my_lower),
          labeller = "label_parsed") +
  ggtitle("Model: b10.10_c") +
  theme(strip.text = element_text(size = 11))
```

In case you were wondering, it turns out you cannot combine `GGally::ggpairs()` plots with syntax from the patchwork package. Check out [issue #52 from the patchwork GitHub repo](https://github.com/thomasp85/patchwork/issues/52) to learn why.

### Example: Exposure and the offset.

> For the last Poisson example, we'll look at a case where the exposure varies across observations. When the length of observation, area of sampling, or intensity of sampling varies, the counts we observe also naturally vary. Since a Poisson distribution assumes that the rate of events is constant in time (or space), it's easy to handle this. All we need to do, as explained on page 312 [of the text], is to add the logarithm of the exposure to the linear model. The term we add is typically called an *offset*. (p. 321, *emphasis* in the original)

Here we simulate our data.

```{r}
set.seed(10)

num_days  <- 30
num_weeks <-  4

y     <- rpois(num_days, 1.5)
y_new <- rpois(num_weeks, 0.5 * 7)
```

Let's make them tidy and add `log_days`.

```{r}
(
  d <- 
  tibble(y         = c(y, y_new), 
         days      = c(rep(1, num_days), rep(7, num_weeks)),
         monastery = c(rep(0, num_days), rep(1, num_weeks))) %>%
  mutate(log_days = log(days))
)
```

With the brms package, you use the `offset()` syntax, in which you put a pre-processed variable like `log_days` or the log of a variable, such as `log(days)`.

```{r b10.15}
b10.15 <-
  brm(data = d, 
      family = poisson,
      y ~ 1 + offset(log_days) + monastery,
      prior = c(prior(normal(0, 100), class = Intercept),
                prior(normal(0, 1), class = b)),
      iter = 2500, warmup = 500, cores = 2, chains = 2,
      seed = 10,
      file = "fits/b10.15")
```

As we look at the model summary, keep in mind that the parameters are on the per-one-unit-of-time scale. Since we simulated the data based on summary information from two units of time--one day and seven days--, this means the parameters are in the scale of $\log (\lambda)$ per one day.

```{r}
print(b10.15)
```

The model summary helps clarify that when you use `offset()`, `brm()` fixes the value. Thus there is no parameter estimate for the `offset()`. It's a fixed part of the model not unlike how the $\nu$ parameter of Student's $t$ gets fixed to infinity when you use the Gaussian likelihood.

To get the posterior distributions for average daily outputs for the old and new monasteries, respectively, we'll use use the formulas

\begin{align*}
\lambda_\text{old} & = \exp (\alpha) \;\;\; \text{and} \\
\lambda_\text{new} & = \exp (\alpha + \beta_\text{monastery}).
\end{align*}

Following those transformations, we'll summarize the $\lambda$ distributions with medians and 89% HDIs with help from the `tidybayes::mean_hdi()` function.

```{r, message = F, warning = F}
library(tidybayes)

as_draws_df(b10.15) %>%
  transmute(lambda_old = exp(b_Intercept),
            lambda_new = exp(b_Intercept + b_monastery)) %>%
  gather() %>%
  mutate(key = factor(key, levels = c("lambda_old", "lambda_new"))) %>%
  group_by(key) %>%
  mean_hdi(value, .width = .89) %>% 
  mutate_if(is.double, round, digits = 2)
```

As McElreath pointed out in the text, "Your estimates will be slightly different, because you got different randomly simulated data" (p. 322). However, if you look back up to our simulation code, those median values are pretty close to the `1.5` and `0.5` values we plugged into the `rpois()` functions.

## Other count regressions

The next two of the remaining four models are maximum entropy distributions for certain problem types. The last two are mixtures, of which we'll see more in the [next chapter][Zero-inflated outcomes].

### Multinomial.

> When more than two types of unordered events are possible, and the probability of each type of event is constant across trials, then the maximum entropy distribution is the multinomial distribution. [We] already met the multinomial, implicitly, in [Chapter 9][Maximum entropy] when we tossed pebbles into buckets as an introduction to maximum entropy. The binomial is really a special case of this distribution. And so its distribution formula resembles the binomial, just extrapolated out to three or more types of events. If there are $K$ types of events with probabilities $p_1, \dots, p_K$, then the probability of observing $y_1, \dots, y_K$ events of each type out of $n$ trials is (p. 323):

$$\Pr (y_1, ..., y_K | n, p_1, ..., p_K) = \frac{n!}{\prod_i y_i!} \prod_{i = 1}^K p_i^{y_i}$$

Compare that equation with the simpler version in section 2.3.1 (page 33 in the text).

#### Explicit multinomial models.

"The conventional and natural link is this context is the *multinomial logit*. This link function takes a vector of *scores*, one for each $K$ event types, and computed the probability of a particular type of event $K$ as" (p. 323, *emphasis* in the original)

$$\Pr(k | s_1, s_2, \dots, s_K) = \frac{\exp (s_k)}{\sum_{i = 1}^K \exp (s_i)}$$

`r emo::ji('warning')`
McElreath then went on to explain how multinomial logistic regression models are among the more difficult of the GLMs to master. He wasn't kidding. To get a grasp on these, we'll cover them in a little more detail, and our section headers will be more granular than those in the text. Whereas McElreath kept all of the material in Section 10.3.1.1 together, we will break things up into subsections 10.3.1.1.1 through 10.3.1.1.3.
`r emo::ji('warning')`

##### "Intercepts"-only.

To begin, let's simulate the data just like McElreath did in the R code 10.56 block.

```{r, warning = F, message = F}
library(rethinking)

# simulate career choices among 500 individuals
n      <- 500           # number of individuals
income <- 1:3           # expected income of each career
score  <- 0.5 * income  # scores for each career, based on income

# next line converts scores to probabilities
p <- softmax(score[1], score[2], score[3])

# now simulate choice
# outcome career holds event type values, not counts
career <- rep(NA, n)  # empty vector of choices for each individual

set.seed(10)
# sample chosen career for each individual
for(i in 1:n) career[i] <- sample(1:3, size = 1, prob = p)
```

Here's what the data look like.

```{r, fig.width = 3, fig.height = 2.25, message = F, warning = F}
tibble(career = career) %>%
  ggplot(aes(x = career)) +
  geom_bar(linewidth = 0, fill = wes_palette("Moonrise2")[2])
```

Our `career` variable is composed of three categories, `1:3`, with each category more likely than the one before. Here's a breakdown of the counts, percentages, and probabilities of each category.

```{r}
tibble(career) %>% 
  count(career) %>% 
  mutate(percent     = (100 * n / sum(n)),
         probability =        n / sum(n))
```

To help build an appreciation for how we simulated data with these proportions and how the process links in with the formulas, above, we'll retrace the first few simulation steps within a tidyverse-centric work flow. Recall how in those first few steps we defined values for `income`, `score`, and `p`. Here they are again in a tibble.

```{r}
tibble(income = 1:3) %>% 
  mutate(score = 0.5 * income) %>% 
  mutate(p = exp(score) / sum(exp(score)))
```

Notice how the values in the `p` column match up well with the `probability` values from the output from the block just above. Our simulation successfully produces data corresponding to the data-generating values. Woot! Also note how the code we just used to compute those `p` values, `p = exp(score) / sum(exp(score))`, corresponds nicely with the formula from above,

$$\Pr(k |s_1, s_2, \dots, s_K) = \frac{\exp (s_k)}{\sum_{i = 1}^K \exp (s_i)}.$$

What still might seem mysterious is what those $s$ values in the equation are. In the simulation and in the prose, McElreath called them *scores*. Another way to think about them is as weights. The thing to get is that their exact values aren't important so much as their difference one from another. You'll note that `score` for `income == 2` was 0.5 larger than that of `income == 1`. The same was true for `income == 3` and `income == 2`. So if we add an arbitrary constant to each of those `score` values, like 104, we'll get the same `p` values.

```{r}
tibble(score = 104 + c(0.5, 1, 1.5)) %>% 
  mutate(p = exp(score) / sum(exp(score)))
```

Now keeping that in mind, recall how McElreath said that though we have $K$ categories, $K = 3$ in this case, we only estimate $K - 1$ linear models. "In a multinomial (or categorical) GLM, you need $K - 1$ linear models for $K$ types of events" (pp. 323--324). Right before he showed the code for `m10.16`, he further wrote:

> We also have to pick one of the event types to be the reference type. We'll use the first one. Instead of getting a linear model, that type is assigned a constant value. Then the other types get linear models that contain parameters relative to the reference type. (p. 324)

In his model code (R code 10.57), you'll see he used zero as that constant value. As it turns out, it is common practice to set the score value for the reference category to zero. It's also a common practice to use the first event type as the reference category. Importantly, in his [-@Bürkner2022Parameterization] vignette, [*Parameterization of response distributions in brms*](https://cran.r-project.org/package=brms/vignettes/brms_families.html#ordinal-and-categorical-models), Bürkner clarified the brms default is to use the first response category as the reference and set it to a zero as well. Returning to our tibble, here are what the `p` values for each `income` level are if we set the `score` for `income == 1` to 0 and have each following `score` value increase by 0.5.

```{r}
tibble(income = 1:3,
       score  = c(0, 0.5, 1)) %>% 
  mutate(p = exp(score) / sum(exp(score)))
```

Those `p` values are still the same as in the prior examples. If our model fitting is successful, our statistical model will return just those probability estimates. To get ready to fit our model, let's switch out rethinking for brms.

```{r, message = F, warning = F}
detach(package:rethinking, unload = T)
library(brms)
```

Before we fit the model, we might take a quick look at the prior structure with `brms::get_prior()`.

```{r}
get_prior(data = list(career = career), 
          family = categorical(link = logit),
          career ~ 1)
```

In brms-parlance, this an Intercepts-only model. We have two "intercepts", which are differentiated in the `dpar` column. We'll talk more about what these are in just a bit; don't worry. I show this here because as of brms 2.12.0, "specifying global priors for regression coefficients in categorical models is deprecated." The upshot is even if we want to use the same prior for both, we need to use the `dpar` argument for each. With that in mind, here's our multinomial model in brms. Do note the specification `family = categorical(link = logit)`.

```{r b10.16}
b10.16 <-
  brm(data = list(career = career), 
      family = categorical(link = logit),
      career ~ 1,
      prior = c(prior(normal(0, 5), class = Intercept, dpar = mu2),
                prior(normal(0, 5), class = Intercept, dpar = mu3)),
      iter = 2500, warmup = 500, cores = 2, chains = 2,
      seed = 10,
      file = "fits/b10.16")
```

Check the results.

```{r}
print(b10.16)
```

`brms::brm()` referred to the $K$ categories as `mu1`, `mu2`, and `mu3`. Since `career == 1` is the reference category, the *score* for which was set to zero, there is no parameter for `mu1_Intercept`. That's a zero. Now notice how `mu2_Intercept` is about 0.5 and `mu3_Intercept` is about 1. That's just like those `score` values from our last tibble block! But these parameters are of *scores* or weights; they are not probabilities. This means just applying the `inv_logit_scaled()` function to them won't work.

```{r}
fixef(b10.16)[, -2] %>% inv_logit_scaled()
```

Those `Estimate` values are not the probability values we're looking for. Why? Because the weights are all relative to one another. The easiest way to get what we want, the probabilities for the three categories, is with `fitted()`. Since this model has no predictors, only intercepts, we won't specify any `newdata`. In such a case, `fitted()` will return fitted values for each case in the data. Going slow, let's take a look at the structure of the output.

```{r}
fitted(b10.16) %>% str()
```

Just as expected, we have 500 rows--one for each case in the original data. We have four summary columns, the typical `Estimate`, `Est.Error`, `Q2.5`, and `Q97.5`. We also have a third dimension composed of three levels, `P(Y = 1)`, `P(Y = 2)`, and `P(Y = 3)`. Those index which of the three `career` categories each probability summary is for. Since the results are identical for each row, we'll simplify the output by only keeping the first row.

```{r}
fitted(b10.16)[1, , ] %>% 
  round(digits = 2)
```

If we take the transpose of that, it will put the results in the order we're more accustomed to.

```{r}
fitted(b10.16)[1, , ] %>% 
  t() %>% 
  round(digits = 2)
```

Now compare those summaries with the empirically-derived `percent` and `probability` values we computed earlier.

```{r}
tibble(career) %>% 
  count(career) %>% 
  mutate(percent     = (100 * n / sum(n)),
         probability =        n / sum(n))
```

We did it!

"Be aware that the estimates you get from these models are extraordinarily difficult to interpret. You absolutely must convert them to a vector of probabilities, to make much sense of them" (p. 325). Indeed. We spent a lot of time fussing about *score* values. But at no time did we really ever care about those. We wanted probabilities! And somewhat maddeningly, the parameters of our `brm()` model were in the metric of $K - 1$ *scores*, not probabilities. *Sigh*.

At least we can get an intuitive diagnostic summary with `pp_check()`.

```{r, fig.width = 5, fig.height = 3.5, message = F}
# this helps us set our custom color scheme
color_scheme_set(wes_palette("Moonrise2")[c(1, 3, 2, 2, 2, 3)])

pp_check(b10.16, type = "hist", binwidth = 1) +
  theme(legend.position = c(.91, .125),
        legend.key = element_rect(color = "transparent"))
```

Our posterior predictive check indicates the model produces synthetic data that resemble the original data.

Before we move on, I have a confession to make. If you look closely at the code McElreath used fo fit his `m10.16`, you'll see it yields a single `b` parameter. But our `b10.16` model has two parameters. *What gives?* Whereas we estimated the score values for `career == 2` and `career == 3` separately, McElreath used an interesting nonlinear syntax to get them with one. We'll discuss this in detail in [Section 10.3.1.1.3][The non-linear syntax is the solution.]. In the meantime, we'll move along to the next example  in the text.

##### Add a predictor into the mix.

Here is the second data simulation, this time based on McElreath's R code 10.58.

```{r, warning = F, message = F}
library(rethinking)

n <- 100

set.seed(10)
# simulate family incomes for each individual
family_income <- runif(n)

# assign a unique coefficient for each type of event
b      <- (1:-1)
career <- rep(NA, n)  # empty vector of choices for each individual

for (i in 1:n) {
    score     <- 0.5 * (1:3) + b * family_income[i]
    p         <- softmax(score[1], score[2], score[3])
    career[i] <- sample(1:3, size = 1, prob = p)
}
```

We might examine what the `family_income` distributions look like across the three levels of `career`. We'll do it in two plots and combine them with the patchwork syntax. The first will be overlapping densities. For the second, we'll display the proportions of `career` across a discretized version of `family_income` in a stacked area plot.

```{r, fig.width = 7, fig.height = 3}
p1 <-
  tibble(career = as.factor(career),
         family_income) %>% 
  
  ggplot(aes(x = family_income, fill = career)) +
  geom_density(linewidth = 0, alpha = 3/4) +
  scale_fill_manual(values = wes_palette("Moonrise2")[c(4, 2, 1)]) +
  theme(legend.position = "none")
  

p2 <-
  tibble(career = as.factor(career),
         family_income) %>% 
  mutate(fi = santoku::chop_width(family_income, width = .2, start = 0, labels = 1:5)) %>% 
  count(fi, career) %>% 
  group_by(fi) %>% 
  mutate(proportion = n / sum(n)) %>% 
  mutate(f = as.double(fi)) %>% 
  
  ggplot(aes(x = (f - 1) / 4, y = proportion, fill = career)) +
  geom_area() +
  scale_fill_manual(values = wes_palette("Moonrise2")[c(4, 2, 1)]) +
  xlab("family_income, descritized")

library(patchwork)

p1 + p2
```

If we were working with a larger $N$, we could have gotten away with discretizing `family_income` into narrower bins. This is about as good as it gets with only 100 cases. It's time to switch out rethinking for brms.

```{r, message = F, warning = F}
detach(package:rethinking, unload = T)
library(brms)
```

Here's the brms version of McElreath's `m10.17`.

```{r b10.17}
b10.17 <-
  brm(data = list(career        = career,  # note how we used a list instead of a tibble
                  family_income = family_income), 
      family = categorical(link = logit),
      career ~ 1 + family_income,
      prior = c(prior(normal(0, 5), class = Intercept, dpar = mu2),
                prior(normal(0, 5), class = Intercept, dpar = mu3),
                prior(normal(0, 5), class = b, dpar = mu2),
                prior(normal(0, 5), class = b, dpar = mu3)),
      iter = 2500, warmup = 500, cores = 2, chains = 2,
      seed = 10,
      file = "fits/b10.17")
```

Check the summary.

```{r}
print(b10.17)
```

Happily, these results cohere with the rethinking model. Fit the model with McElreath's `rethinking::map()` code and you'll see. "Again, computing implied predictions is the safest way to interpret these models. They do a great job of classifying discrete, unordered events. But the parameters are on a scale that is very hard to interpret" (p. 325). Like before, we'll do that with `fitted()`. Now we have a predictor, this time we will use the `newdata` argument.

```{r}
nd <- tibble(family_income = seq(from = 0, to = 1, length.out = 60))

f <-
  fitted(b10.17,
         newdata = nd)
```

First we'll plot the fitted probabilities for each `career` level across the full range of `family_income` values.

```{r, fig.width = 7, fig.height = 2.75}
# wrangle
rbind(f[, , 1],
      f[, , 2],
      f[, , 3]) %>% 
  data.frame() %>% 
  bind_cols(nd %>% 
              expand_grid(career = 1:3) %>% 
              arrange(career, family_income)) %>% 
  mutate(career = str_c("career: ", career)) %>% 
  
  # plot
  ggplot(aes(x = family_income, y = Estimate,
             ymin = Q2.5, ymax = Q97.5)) +
  geom_ribbon(aes(fill = career),
              alpha = 2/3) +
  geom_line(aes(color = career), 
            linewidth = 3/4) +
  scale_fill_manual(values = wes_palette("Moonrise2")[c(4, 2, 1)]) +
  scale_color_manual(values = wes_palette("Moonrise2")[c(4, 2, 1)]) +
  scale_x_continuous(breaks = 0:2 / 2) +
  scale_y_continuous("probability", limits = c(0, 1),
                     breaks = 0:3 / 3,
                     labels = c("0", ".33", ".67", "1")) +
  theme(axis.text.y = element_text(hjust = 0),
        legend.position = "none") +
  facet_wrap(~career)
```

If we're willing to summarize those fitted lines by their posterior means, we could also make a model-implied version of the stacked area plot from above.

```{r, fig.width = 3.25, fig.height = 3}
# annotation
text <-
  tibble(family_income = c(.25, .5, .75),
         proportion    = c(.2, .5, .8),
         label         = str_c("career: ", 3:1),
         color         = c("a", "a", "b"))

# wrangle
rbind(f[, , 1],
      f[, , 2],
      f[, , 3]) %>% 
  data.frame() %>% 
  bind_cols(nd %>% 
              expand_grid(career = 1:3) %>% 
              arrange(career, family_income)) %>% 
  group_by(family_income) %>% 
  mutate(proportion = Estimate / sum(Estimate),
         career     = factor(career)) %>% 
  
  # plot!
  ggplot(aes(x = family_income, y = proportion)) +
  geom_area(aes(fill = career)) +
  geom_text(data = text,
            aes(label = label, color = color),
            family = "Times", size = 4.25) +
  scale_color_manual(values = wes_palette("Moonrise2")[4:3]) +
  scale_fill_manual(values = wes_palette("Moonrise2")[c(4, 2, 1)]) +
  theme(legend.position = "none")
```

##### The non-linear syntax is the solution.

One of the things that differentiates this ebook with my [-@kurzStatisticalRethinkingSecondEd2023] [translation](https://bookdown.org/content/4857/) of McElreath's [-@mcelreathStatisticalRethinkingBayesian2020] 2nd edition is the non-linear syntax. Virtually all of the models in this book can be handled with what you might call the conventional brms syntax. However, brms offers another very flexible way of specifying models with what Bürkner calls the non-linear syntax. For a detailed introduction, see Bürkner's [-@Bürkner2022Non_linear] vignette, [*Estimating non-linear models with brms*](https://CRAN.R-project.org/package=brms/vignettes/brms_nonlinear.html). McElreath has peppered his 2nd edition with models that require this non-linear syntax, which means readers of my translation of the 2nd edition get a lot of practice using the non-linear syntax. But for this first edition, McElreath's `m10.16` is the only model requiring the non-linear syntax. In this section, I'll provide a brief introduction.

First, let's simulate the data from McElreath's R code 10.56 block again.

```{r, warning = F, message = F}
library(rethinking)

# simulate career choices among 500 individuals
n      <- 500           # number of individuals
income <- 1:3           # expected income of each career
score  <- 0.5 * income  # scores for each career, based on income

# next line converts scores to probabilities
p <- softmax(score[1], score[2], score[3])

# now simulate choice
# outcome career holds event type values, not counts
career <- rep(NA, n)  # empty vector of choices for each individual

set.seed(10)
# sample chosen career for each individual
for(i in 1:n) career[i] <- sample(1:3, size = 1, prob = p)
```

There are at least two alternative ways to fit our `b10.16`, which is based on the conventional brms syntax. The first uses what we might call a verbose version of the conventional syntax. We'll call it `b10.16_verbose`. The second uses the non-linear syntax. We'll call that one `b10.16_nonlinear`. Fit the models.

```{r}
# verbose syntax
b10.16_verbose <-
  brm(data = list(career = career), 
      family = categorical(link = logit),
      bf(career ~ 1,
         mu2 ~ 1,
         mu3 ~ 1),
      prior = c(prior(normal(0, 5), class = Intercept, dpar = mu2),
                prior(normal(0, 5), class = Intercept, dpar = mu3)),
      iter = 2500, warmup = 500, cores = 2, chains = 2,
      seed = 10,
      file = "fits/b10.16_verbose")

# nonlinear syntax
b10.16_nonlinear <-
  brm(data = list(career = career), 
      family = categorical(link = logit),
      bf(career ~ 1,
         nlf(mu2 ~ a2),
         nlf(mu3 ~ a3),
         a2 + a3 ~ 1),
      prior = c(prior(normal(0, 5), class = b, nlpar = a2),
                prior(normal(0, 5), class = b, nlpar = a3)),
      iter = 2500, warmup = 500, cores = 2, chains = 2,
      seed = 10,
      file = "fits/b10.16_nonlinear")
```

We might use `fixef()` to show that the parameter summaries are the same for all three variants--differing only by simulation variance.

```{r}
fixef(b10.16) %>% round(digits = 2)
fixef(b10.16_verbose) %>% round(digits = 2)
fixef(b10.16_nonlinear) %>% round(digits = 2)
```

I point this out because it's the non-linear approach that will allow us to fit a model like McElreath's `m10.16`. My hope is the syntax we used in the `b10.16_verbose` model will help clarify what's going on with the non-linear syntax. When we fit multinomial models with brms, the terse conventional `formula` syntax might not make clear how there are actually $K - 1$ formulas. The more verbose syntax of our `b10.16_verbose` model shows how we can specify those models directly. In our case, that was with those `mu2 ~ 1, mu3 ~ 1` lines. When we switch to the non-linear syntax, we explicitly model `mu2` and `mu3` and, as is typical of the non-linear syntax, we name our parameters. You can see another comparison of these three ways of fitting a multinomial model at the [Nonlinear syntax with a multinomial model?](https://discourse.mc-stan.org/t/nonlinear-syntax-with-a-multinomial-model/16122) thread on the Stan Forums.

Now it's time to focus on the correct brms version of McElreath's `m10.16`. I'm going to call this `b10.16_true`.

```{r}
b10.16_true <-
  brm(data = list(career = career), 
      family = categorical(link = logit),
      bf(career ~ 1,
         nlf(mu2 ~ b * 2),
         nlf(mu3 ~ b * 3),
         b ~ 1),
      prior(normal(0, 5), class = b, nlpar = b),
      iter = 2500, warmup = 500, cores = 2, chains = 2,
      seed = 10,
      file = "fits/b10.16_true")
```

What did we just estimate?

```{r}
print(b10.16_true)
```

This summary is probably even more difficult to interpret than the summary for `b10.16`. Getting these posterior draws out of the log-odds metric will help.

```{r, warning = F, message = F}
library(tidybayes)

as_draws_df(b10.16_true) %>% 
  transmute(b = inv_logit_scaled(b_b_Intercept)) %>% 
  mean_qi(b) %>% 
  mutate_if(is.double, round, digits = 2)
```

The posterior for `b` is about 0.59. What might that be? Well, let's spell this out by substituting it into the model `formula` for `b10.16b`. We get `mu2 ~ 0.59 * 2` and `mu3 ~ 0.59 * 3`. Now look back at the first few lines of code from McElreath's R code 10.56.

```{r, eval = F}
# simulate career choices among 500 individuals
n      <- 500           # number of individuals
income <- 1:3           # expected income of each career
score  <- 0.5 * income  # scores for each career, based on income
```

Our `mu2` is the same as the second score value. Our 0.59 is our estimate for the 0.5 value in the bottom line. The `* 2` part in our `formula` syntax is the same as `* income` in the bottom line. What our non-linear model did was allow us to estimate the 0.5 constant we multiplied the `income` values by to simulate the original `score` data.

You may be wondering what we might do with our vector of `b_b_Intercept` draws. Well, after converting the draws out of the log-odds scale, we can carefully multiply them by our three `income` values, which will return the posteriors for the three score values. We can then use the formula form above,

$$\Pr(k |s_1, s_2, ..., s_K) = \frac{\exp (s_k)}{\sum_{i = 1}^K \exp (s_i)},$$

to return the posterior probabilities for each of the career choices based on their `income` values.

```{r, warning = F}
as_draws_df(b10.16_true) %>% 
  transmute(draw = .draw,
            s1   = inv_logit_scaled(b_b_Intercept) * income[1],
            s2   = inv_logit_scaled(b_b_Intercept) * income[2],
            s3   = inv_logit_scaled(b_b_Intercept) * income[3]) %>% 
  gather(key, score, -draw) %>% 
  mutate(income = str_remove(key, "s")) %>% 
  group_by(draw) %>% 
  # use the formula
  mutate(p = exp(score) / sum(exp(score))) %>% 
  group_by(income) %>% 
  mean_qi(p) %>% 
  mutate_if(is.double, round, digits = 2)
```

Those are fairly close to the empirical probabilities based on the data-generating values.

```{r}
tibble(income = income,
       score  = score) %>% 
  mutate(p = exp(score) / sum(exp(score)))
```

I'm not going to dive any further into the brms non-linear syntax in this ebook. If you want more, check out Bürkner's vignette, [*Estimating non-linear models with brms*](https://CRAN.R-project.org/package=brms/vignettes/brms_nonlinear.html), or [my translation](https://bookdown.org/content/4857/) of McElreath's 2nd edition. For more practice fitting multinomial models with brms, you might also check out my [translation of Chapter 22](https://bookdown.org/content/3686/nominal-predicted-variable.html) of Kruschke's [-@kruschkeDoingBayesianData2015] text.

#### Multinomial in disguise as Poisson.

Here we fit a multinomial likelihood by refactoring it to a series of Poisson's. Let's retrieve the Berkeley data.

```{r, warning = F, message = F}
library(rethinking)

data(UCBadmit)
d <- UCBadmit
rm(UCBadmit)

detach(package:rethinking, unload = T)
library(brms)
```

Fit the models.

set_rescor(FALSE)

```{r, eval = F, echo = F}
get_prior(data = d %>%
        mutate(rej = reject),  # 'reject' is a reserved word
      family = poisson,
      mvbind(admit, rej) ~ 1)

get_prior(data = d %>%
        mutate(rej = reject),  # 'reject' is a reserved word
      family = poisson,
      bf(mvbind(admit, rej) ~ 1) + set_rescor(FALSE))
```

```{r b10.binom}
# binomial model of overall admission probability
b10.binom <-
  brm(data = d, 
      family = binomial,
      admit | trials(applications) ~ 1,
      prior = prior(normal(0, 100), class = Intercept),
      iter = 2000, warmup = 1000, cores = 3, chains = 3,
      seed = 10,
      file = "fits/b10.binom")

# Poisson model of overall admission rate and rejection rate
b10.pois <-
  brm(data = d %>%
        mutate(rej = reject),  # 'reject' is a reserved word
      family = poisson,
      bf(mvbind(admit, rej) ~ 1) + set_rescor(FALSE),
      prior = c(prior(normal(0, 100), class = Intercept, resp = admit),
                prior(normal(0, 100), class = Intercept, resp = rej)),
      iter = 2000, warmup = 1000, cores = 3, chains = 3,
      seed = 10,
      file = "fits/b10.pois")
```

Note, the `mvbind()` syntax made `b10.pois` a multivariate Poisson model. Starting with version 2.0.0, brms supports a variety of multivariate models, which you might learn al about in Bürkner's [-@Bürkner2022Multivariate] vignette, [*Estimating multivariate models with brms*](https://cran.r-project.org/package=brms/vignettes/brms_multivariate.html). Anyway, here are the implications of `b10.pois`.

```{r, fig.height = 2.5, fig.width = 6.5, warning = F}
# extract the samples
post <- as_draws_df(b10.pois)

# wrangle
post %>%
  transmute(admit  = exp(b_admit_Intercept), 
            reject = exp(b_rej_Intercept)) %>% 
  gather() %>% 
  
  # plot
  ggplot(aes(x = value, y = key, fill = key)) +
  stat_halfeye(point_interval = median_qi, .width = .95,
               color = wes_palette("Moonrise2")[4]) +
  scale_fill_manual(values = c(wes_palette("Moonrise2")[1],
                               wes_palette("Moonrise2")[2])) +
  scale_y_discrete(expand = expansion(add = 0.1)) +
  labs(title = " Mean admit/reject rates across departments",
       x = "# applications",
       y = NULL) +
  theme(axis.ticks.y = element_blank(),
        legend.position = "none")
```

We might compare the model summaries.

```{r}
summary(b10.binom)$fixed
summary(b10.pois)$fixed
```

Here's the posterior mean for the probability of admission, based on `b10.binom`.

```{r}
fixef(b10.binom)[, "Estimate"] %>%
  inv_logit_scaled()
```

Happily, we get the same value within simulation error from model `b10.pois`.

```{r}
k <- 
  fixef(b10.pois) %>%
  as.numeric()

exp(k[1]) / (exp(k[1]) + exp(k[2]))
```

The formula for what we just did in code is

$$p_\text{admit} = \frac{\lambda_1}{\lambda_1 + \lambda_2} = \frac{\exp (\alpha_1)}{\exp (\alpha_1) + \exp (\alpha_2)}.$$

To get a better appreciation on how well the two model types converge on the same solution, we might plot the full poster for admissions probability from each.

```{r, fig.width = 4.5, fig.height = 2.5, message = F , warning = F}
# wrangle
bind_cols(
  as_draws_df(b10.pois) %>% 
    transmute(`the Poisson`  = exp(b_admit_Intercept) / (exp(b_admit_Intercept) + exp(b_rej_Intercept))),
  as_draws_df(b10.binom) %>% 
    transmute(`the binomial` = inv_logit_scaled(b_Intercept))
  ) %>% 
  pivot_longer(everything()) %>% 

  # plot
  ggplot(aes(x = value, y = name, fill = name)) +
  stat_halfeye(point_interval = median_qi, .width = c(.95, .5),
               color = wes_palette("Moonrise2")[4]) +
  scale_fill_manual(values = c(wes_palette("Moonrise2")[2:1])) +
  labs(title = "Two models, same marginal posterior",
       x = "admissions probability",
       y = NULL) +
  scale_y_discrete(expand = expansion(add = 0.1)) +
  theme(axis.text.y = element_text(hjust = 0),
        axis.ticks.y = element_blank(),
        legend.position = "none")
```

### Geometric.

> Sometimes a count variable is a number of events up until something happened. Call this "something" the terminating event. Often we want to model the probability of that event, a kind of analysis known as event history analysis or survival analysis. When the probability of the terminating event is constant through time (or distance), and the units of time (or distance) are discrete, a common likelihood function is the geometric distribution. This distribution has the form:
>
> $$\Pr(y | p) = p (1 - p) ^{y - 1}$$
>
> where $y$ is the number of time steps (events) until the terminating event occurred and $p$ is the probability of that event in each time step. This distribution has maximum entropy for unbounded counts with constant expected value. (pp. 327--328)

Here we simulate exemplar data.

```{r}
# simulate
n <- 100

set.seed(10)
x <- runif(n)

set.seed(10)
y <- rgeom(n, prob = inv_logit_scaled(-1 + 2 * x))
```

In case you're curious, here are the data.

```{r, fig.width = 4, fig.height = 2.5}
list(x = x, y = y) %>%
  as_tibble() %>%
  ggplot(aes(x = x, y = y)) +
  geom_point(size = 3/5, alpha = 2/3)
```

We fit the geometric model by setting `family = geometric(link = log)`.

```{r b10.18}
b10.18 <-
  brm(data = list(y = y, x = x), 
      family = geometric(link = log),
      y ~ 0 + Intercept + x,
      prior = c(prior(normal(0, 10), class = b, coef = Intercept),
                prior(normal(0, 1), class = b, coef = x)),
      iter = 2500, warmup = 500, chains = 2, cores = 2,
      seed = 10,
      file = "fits/b10.18")
```

Inspect the results.

```{r}
print(b10.18, digits = 2)
```

It turns out brms uses a [different parameterization for the geometric distribution](https://cran.r-project.org/package=brms/vignettes/brms_families.html#binary-and-count-data-models) than rethinking does. It follows the form

$$f(y_i) = {y_i \choose y_i} \left (\frac{\mu_i}{\mu_i + 1} \right )^{y_i} \left (\frac{1}{\mu_i + 1} \right ).$$

Even though the parameters brms yielded look different from those in the text, their predictions describe the data well. Here's the `conditional_effects()` plot.

```{r, fig.width = 4, fig.height = 2.5}
conditional_effects(b10.18) %>% 
  plot(points = T,
       point_args = c(size = 3/5, alpha = 2/3),
       line_args = c(color = wes_palette("Moonrise2")[1],
                     fill = wes_palette("Moonrise2")[1]))
```

## Summary

> This chapter described some of the most common generalized linear models, those used to model counts. It is important to never convert counts to proportions before analysis, because doing so destroys information about sample size. A fundamental difficulty with these models is that the parameters are on a different scale, typically log-odds (for binomial) or log-rate (for Poisson), than the outcome variable they describe. Therefore computing implied predictions is even more important than before. (pp. 328--329)

## Session info {-}

```{r}
sessionInfo()
```

```{r, echo = F}
rm(d, b10.1, b10.2, b10.3, post, d_plot, b10.4, d_plot_4, f, d_aggregated, b10.5, b10.6, b10.7, l_b10.6, l_b10.7, l_b10.6_mm, l_b10.7_mm, p, text, b10.8, b10.9, l_b10.8_reloo, l_b10.9_reloo, w, y, x, b10.good, b10.10, point_tibble, line_tibble, b10.11, b10.12, b10.13, b10.14, nd, ppa, b10.10_c, my_upper, my_diag, my_lower, num_days, num_weeks, y_new, b10.15, n, income, score, career, i, b10.16, family_income, b, p1, p2, b10.17, k, b10.16_verbose, b10.16_nonlinear, b10.16_true, b10.binom, b10.pois, b10.18)
```

```{r, echo = F, message = F, warning = F, results = "hide"}
ggplot2::theme_set(ggplot2::theme_grey())
bayesplot::color_scheme_set("blue")
pacman::p_unload(pacman::p_loaded(), character.only = TRUE)
```