Generative Modeling and Prior Predictive Simulation for Response Rate

1 Overview

This document builds a Bayesian model for immunotherapy response probability using a generative modeling workflow inspired by Statistical Rethinking (McElreath).

Rather than beginning with the real dataset, we first construct and validate the statistical model using simulated data. This allows us to verify that:

• the model is correctly specified
• the priors behave reasonably
• the model can recover known parameter values
• the generative assumptions produce plausible datasets

The workflow follows these steps:

1. Specify the generative model mathematically
2. Simulate synthetic data from the model
3. Perform prior predictive checks
4. Fit the model using ulam()
5. Evaluate whether the model recovers the true parameters
6. Extend the model incrementally with additional predictors

This approach helps ensure that the model structure is sound before applying it to the real clinical dataset.

The first model we consider is the simplest possible case: an intercept-only Bernoulli model for response probability.

2 Load Packages

library(tidyverse)

Warning: package 'tibble' was built under R version 4.4.1

Warning: package 'purrr' was built under R version 4.4.1

── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr     1.1.4     ✔ readr     2.1.5
✔ forcats   1.0.0     ✔ stringr   1.5.1
✔ ggplot2   3.5.1     ✔ tibble    3.3.0
✔ lubridate 1.9.3     ✔ tidyr     1.3.1
✔ purrr     1.0.4     
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag()    masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

library(brms)

Warning: package 'brms' was built under R version 4.4.1

Loading required package: Rcpp
Loading 'brms' package (version 2.22.0). Useful instructions
can be found by typing help('brms'). A more detailed introduction
to the package is available through vignette('brms_overview').

Attaching package: 'brms'

The following object is masked from 'package:stats':

    ar

source(here::here("scripts/load_packages.R"))

Attaching package: 'janitor'

The following objects are masked from 'package:stats':

    chisq.test, fisher.test

here() starts at /Users/davidmiller/Partners HealthCare Dropbox/David Miller/mLab/Projects/FIRST and Neoadjuvant Outcomes in CSCC at MGH-MEEI

Warning: package 'fs' was built under R version 4.4.1

Attaching package: 'rvest'

The following object is masked from 'package:readr':

    guess_encoding

Loading required package: future

Warning: package 'rlang' was built under R version 4.4.1

Attaching package: 'rlang'

The following object is masked from 'package:xml2':

    as_list

The following objects are masked from 'package:purrr':

    %@%, flatten, flatten_chr, flatten_dbl, flatten_int, flatten_lgl,
    flatten_raw, invoke, splice

Warning: package 'gt' was built under R version 4.4.1

Warning: package 'bayesplot' was built under R version 4.4.1

This is bayesplot version 1.13.0
- Online documentation and vignettes at mc-stan.org/bayesplot
- bayesplot theme set to bayesplot::theme_default()
   * Does _not_ affect other ggplot2 plots
   * See ?bayesplot_theme_set for details on theme setting

Attaching package: 'bayesplot'

The following object is masked from 'package:brms':

    rhat


Attaching package: 'survival'

The following object is masked from 'package:future':

    cluster

The following object is masked from 'package:brms':

    kidney

Loading required package: ggpubr

Attaching package: 'survminer'

The following object is masked from 'package:survival':

    myeloma

Loading required package: cmdstanr
This is cmdstanr version 0.8.0
- CmdStanR documentation and vignettes: mc-stan.org/cmdstanr
- CmdStan path: /Users/davidmiller/.cmdstan/cmdstan-2.37.0
- CmdStan version: 2.37.0

A newer version of CmdStan is available. See ?install_cmdstan() to install it.
To disable this check set option or environment variable cmdstanr_no_ver_check=TRUE.
Loading required package: posterior

Warning: package 'posterior' was built under R version 4.4.1

This is posterior version 1.6.1

Attaching package: 'posterior'

The following object is masked from 'package:bayesplot':

    rhat

The following objects are masked from 'package:stats':

    mad, sd, var

The following objects are masked from 'package:base':

    %in%, match

Loading required package: parallel
rethinking (Version 2.42)

Attaching package: 'rethinking'

The following objects are masked from 'package:brms':

    LOO, stancode, WAIC

The following object is masked from 'package:purrr':

    map

The following object is masked from 'package:stats':

    rstudent

library(rethinking)

3 Intercept-Only Generative Model

We begin with the simplest possible model in which each patient’s response is generated from a Bernoulli distribution with probability \(p_i\).

The log-odds of response are determined by a single intercept parameter \(\alpha\), which represents the baseline response probability in the population.

We center the prior for \(\alpha\) at a response probability of 40%, based on approximate clinical expectations.

\[ \begin{aligned} y_i &\sim \text{Bernoulli}(p_i) \\ \text{logit}(p_i) & = \alpha \\ \alpha &\sim \text{Normal}(\text{logit}(0.40),\,1.5) \end{aligned} \]

4 Choose True Parameter Value

alpha_true <- qlogis(0.4) # 40% response rate
alpha_true

[1] -0.4054651

The value above is the log-odds corresponding to a 40% response probability:

\[ \alpha = \text{logit}(0.40) \]

This value serves as the center of our prior for the intercept.

5 Simulate Data

set.seed(123)

N <- 189
alpha_true <- qlogis(0.4) # 40% Response Rate

d_sim_intercept <- tibble(
  patient_id = 1:N,
  p = plogis(alpha_true),
  y = rbinom(N, size = 1, prob = p)
)

6 Inspect Simulated Dataset

mean(d_sim_intercept$y)

[1] 0.3862434

table(d_sim_intercept$y)

  0   1 
116  73 

Out of 189 simulated patients:

• 73 responders
• 116 non-responders

This is consistent with a response probability near 40%.

d_sim_intercept$p[1:4]

[1] 0.4 0.4 0.4 0.4

all contain alpha of 0.4 (40% response rate), which is the right format for the binomial likelihood

d_sim_intercept$y

  [1] 0 1 0 1 1 0 0 1 0 0 1 0 1 0 0 1 0 0 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 1 0 0 1
 [38] 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 1 1 0 1 0 0 0 1 0 1 1 1 0 1 1 1 0
 [75] 0 0 0 1 0 0 0 1 0 1 0 0 1 1 1 0 0 1 0 1 0 0 1 0 0 0 0 0 0 1 0 1 1 1 0 0 1
[112] 0 0 1 1 0 0 1 0 0 1 0 0 0 0 1 0 0 0 1 1 1 1 1 0 1 1 1 1 0 0 0 0 0 1 0 0 0
[149] 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 1 0 1 1 1 1 0 0 1 0 1 0 1 0 0
[186] 0 0 0 1

6.1 What is d_sim_intercept$y?

d_sim_intercept$y is a vector of simulated patient outcomes generated from the Bernoulli distribution defined in the generative model.

In the model specification:

\[ \begin{aligned} y_i &\sim \text{Bernoulli}(p_i) \\ \text{logit}(p_i) &= \alpha \\ \alpha &\sim \text{Normal}(\text{logit}(0.40),\,1.5) \end{aligned} \] each observation \(y_i\) represents the binary response outcome for patient \(i\).

For example:
- \(y_i\) = 1 → patient responded (CR or PR)
- \(y_i\) =0 → patient did not respond

Because the Bernoulli distribution only produces two outcomes, the simulated data must consist of only 0s and 1s.

This gives you a simulated dataset where the only thing going on is a baseline response probability of about 40%.

6.2 Format for ulam

dat_intercept <- list(
  N = nrow(d_sim_intercept),
  y = d_sim_intercept$y
)

This creates a named list of data objects that will be passed to the Stan model generated by ulam(). Unlike brms, which takes a full data frame and parses the variables automatically, ulam() expects you to explicitly supply the variables used in the model. So you create a list that contains exactly the objects referenced inside the model.

Why a list is required

When you run:

ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha,
    alpha ~ normal(qlogis(0.4), 1.5)
  ),
  data = dat_intercept
)

ulam() translates this model into Stan code.

Stan does not know anything about R data frames. It only understands vectors, scalars, and arrays that are explicitly provided.

So the list becomes the Stan data block.

Conceptually, the Stan model needs something like:

data {
    int N;
    int y[N];
}

Breaking down the two elements

1️⃣ N = nrow(d_sim_intercept)

This defines the number of observations in the dataset.

Your list provides those values.

So N tells Stan:

“There are N independent Bernoulli observations.”

2️⃣ y = d_sim_intercept$y

This extracts the vector of outcomes.

Example:

[1] 1 0 0 1

This becomes the observed data for the model:

\(y_i\) ~ Bernoulli(\(p_i\))

So Stan receives something like:

y = [1,0,0,1]

Why we don’t pass the entire dataframe

If we passed:

data = d_sim_intercept

Stan would not know what to do with the columns.

ulam() expects something closer to:

list( variable_name = object, variable_name = object )

How it maps to the model

Your model says:

\(y_i\) ~ Bernoulli(\(p_i\))

So Stan needs:
- the number of observations N - the vector of observed outcomes y

The list provides exactly those two pieces.

Conceptual diagram

You can think of it like this:

7 Simulated dataframe

patient_id y 1 1 2 0 3 1 4 0

8 Extract pieces needed by the model

N = 4 y = [1,0,1,0]

9 Pack them into a list

dat_intercept = list( N = 4, y = [1,0,1,0] )

This list is then passed to ulam().

Why this becomes powerful later

This explicit structure becomes very helpful when the model grows.

For example later we might add:

dose dose_intensity age ecog agent

Then the list might look like:

dat_model <- list(

dat_model <- list(
  N = nrow(df),
  y = df$response,
  dose = df$dose_minus_1_pre,
  dose_intensity = df$dose_intensity_pre,
  age = df$age_centered,
  ecog = df$ecog,
  agent = df$agent_index
)

N = nrow(df),

y = df$response,

dose = df$dose_minus_1_pre,

dose_intensity = df$dose_intensity_pre,

age = df$age_centered,

ecog = df$ecog,

agent = df$agent_index

)

Each variable in the model must appear in this list.

A useful rule of thumb

When using ulam(), every variable appearing in the model:

y ~ bernoulli(p)
logit(p) <- alpha + beta * x

must exist inside the data list. So you need:

list(
N = number of rows
y = outcome vector
x = predictor vector
)

9.1 Fit the intercept-only model to the simulated data

alpha_mu <- qlogis(0.4)  # prior center = 40% response on probability scale

dat_intercept <- list(
  N = nrow(d_sim_intercept),   # number of observations
  y = d_sim_intercept$y,       # binary response vector
  alpha_mu = alpha_mu          # prior mean for intercept
)

# Note: although written top -> bottom, the model is generative and runs
# conceptually bottom -> top:
#   1. alpha is drawn from its prior
#   2. p is computed from alpha via the logit link
#   3. y is generated from Bernoulli(p)

m_intercept <- ulam(
  alist(
    y ~ bernoulli(p),                 # likelihood: observed responses are Bernoulli draws
    logit(p) <- alpha,                # linear model: intercept sets log-odds of response
    alpha ~ normal(alpha_mu, 1.5)     # prior: baseline response centered at 40%
  ),
  data = dat_intercept,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 0.0 seconds.
Chain 2 finished in 0.0 seconds.
Chain 3 finished in 0.0 seconds.
Chain 4 finished in 0.0 seconds.

All 4 chains finished successfully.
Mean chain execution time: 0.0 seconds.
Total execution time: 0.3 seconds.

• qlogis() is an R function, not a Stan function.

• Because ulam() compiles the model to Stan, any transformed constants

• should be computed in R first and then passed into the model as data.

9.2 Check whether it recovers the truth

precis(m_intercept, depth = 2)

            mean        sd       5.5%      94.5%     rhat ess_bulk
alpha -0.4682212 0.1441836 -0.6981753 -0.2351045 1.000486 1565.987

9.2.1 Interpreting the Posterior Summary

We fit the intercept-only model to the simulated dataset and summarize the posterior distribution of the parameter using:

precis(m_intercept, depth = 2)

This function from the rethinking package provides a compact summary of the posterior distribution. The output is:

       mean   sd  5.5% 94.5% rhat ess_bulk
alpha -0.46 0.15 -0.69 -0.22    1  1028.07

Posterior mean:
mean = -0.46

This is the posterior mean estimate of the intercept \(α\)

Recall that in the simulation we set the true value to:

\(α_true\) = logit(0.40) ≈ −0.405

The posterior estimate (-0.46) is close to this value, indicating that the model is successfully recovering the true parameter used to generate the data.

Posterior standard deviation

sd = 0.15

This is the posterior uncertainty about the intercept after observing the data. Smaller values indicate greater certainty about the parameter.

Posterior credible interval

5.5% = -0.69

94.5% = -0.22

These are the 89% credible interval bounds, which are the default in Statistical Rethinking.

P( −0.69 < α < −0.22 ∣ data ) ≈ 0.89

The true value: \(α_true\) ≈ −0.405

falls comfortably within this interval, which is what we hope to see when fitting a model to data generated from the same model.

9.2.2 R-hat (convergence diagnostic)

rhat = 1

The R-hat statistic evaluates whether the Markov chains have converged.

Values close to 1.00 indicate good convergence.

Rules of thumb:

< 1.01 → excellent

< 1.05 → acceptable

1.05 → potential convergence problems

9.2.3 Effective sample size

ess_bulk = 1028

This is the effective sample size of the posterior draws.

Although we ran 4000 total samples (4 chains × 1000 post-warmup iterations), autocorrelation in the chains means the effective number of independent samples is smaller.

A value around 1000 is very good for a simple model like this.

9.3 Prior Predictive Checks

9.3.1 Extract Posterior Samples

class(m_intercept)

[1] "ulam"
attr(,"package")
[1] "rethinking"

post_intercept <- extract.samples(m_intercept)
nrow(post_intercept$alpha)

[1] 4000

head(post_intercept$alpha)

           [,1]
[1,] -0.2984566
[2,] -0.3051344
[3,] -0.6897837
[4,] -0.6921704
[5,] -0.6650424
[6,] -0.7076541

• extract.samples() pulls posterior draws from the fitted model.
  
• post_intercept$alpha is a vector containing thousands of sampled.
  
• values of the intercept parameter from the posterior distribution.

9.3.2 Generate Prior Samples

We simulate samples directly from the prior

set.seed(123)

n_prior <- 4000

prior_intercept <- rnorm(
  n_prior,
  mean = alpha_mu,
  sd = 1.5
)

• These draws represent what we believed about alpha BEFORE seeing any data.

9.3.3 Combine prior and posterior

prior_df <- tibble(
  alpha = prior_intercept,
  source = "Prior"
)

posterior_df <- tibble(
  alpha = post_intercept$alpha,
  source = "Posterior"
)

alpha_plot_df <- bind_rows(
  prior_df,
  posterior_df
)

9.3.4 Plot on the log-odds scale

ggplot(alpha_plot_df, aes(x = alpha, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  geom_vline(xintercept = alpha_mu, linetype = "dashed") +
  labs(
    title = "Prior vs Posterior for Intercept (log-odds scale)",
    x = expression(alpha),
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) 

The dashed vertical line shows the prior center corresponding to a 40% response probability.

9.3.5 Convert to probability scale

alpha_plot_df <- alpha_plot_df |>
  mutate(
    p = plogis(alpha)
  )

9.3.6 Plot response probability

ggplot(alpha_plot_df, aes(x = p, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  geom_vline(xintercept = 0.4, linetype = "dashed") +
  labs(
    title = "Prior vs Posterior for Baseline Response Probability",
    x = "Response Probability",
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) 

10 Prior vs Posterior

The prior distribution for the intercept represented a wide range of plausible response probabilities centered around 40%.

After observing the simulated data, the posterior distribution becomes narrower and shifts slightly based on the observed response rate.

This demonstrates how Bayesian inference updates prior beliefs using observed data.

11 Posterior Predictive Check

Next, we use the fitted model to generate new simulated datasets from the posterior distribution. This posterior predictive check evaluates whether the model can plausibly reproduce the observed response rate in the simulated dataset.

For each posterior draw of the intercept parameter \(alpha\), we compute the implied response probability and simulate a new Bernoulli dataset of the same size as the original. We then compare the distribution of simulated response rates to the observed response rate.

\[ \alpha \rightarrow p \rightarrow y \] \[ \begin{aligned} \alpha &\sim p(\alpha \mid y) \\ p &= \text{logit}^{-1}(\alpha) \\ \tilde{y}_i &\sim \text{Bernoulli}(p) \end{aligned} \]

# Observed response rate in the simulated dataset
observed_rate <- mean(d_sim_intercept$y)

# Posterior predictive simulation:
# For each posterior draw of alpha, simulate a new dataset of size N
# and record the overall response rate.
set.seed(123)

pp_rates <- sapply(post_intercept$alpha, function(a) {
  p <- plogis(a)                                  # convert log-odds to probability
  y_rep <- rbinom(dat_intercept$N, size = 1, prob = p)  # simulate new binary outcomes
  mean(y_rep)                                     # summarize by response rate
})

pp_df <- tibble(
  simulated_response_rate = pp_rates
)

nrow(pp_df)

[1] 4000

# Quick numerical summary
pp_df |>
  summarise(
    mean_rate = mean(simulated_response_rate),
    median_rate = median(simulated_response_rate),
    q05 = quantile(simulated_response_rate, 0.055),
    q95 = quantile(simulated_response_rate, 0.945)
  )

# A tibble: 1 × 4
  mean_rate median_rate   q05   q95
      <dbl>       <dbl> <dbl> <dbl>
1     0.386       0.386 0.312 0.460

11.0.1 Plot

ggplot(pp_df, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(xintercept = observed_rate, color = "red", linewidth = 1.2, linetype = "dashed") +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Overall Response Rate",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

11.0.1.1 Interpretation

The histogram shows the distribution of response rates generated from simulated datasets drawn from the posterior predictive distribution.

Each bar represents the response rate from a dataset simulated using one posterior draw of the intercept parameter \(alpha\).

The red dashed line indicates the observed response rate in the simulated dataset used to fit the model.

Because the observed response rate falls comfortably within the center of the posterior predictive distribution, the model is able to generate datasets that resemble the observed data. This indicates that the intercept-only model provides a reasonable description of the data-generating process used in this simulation.

Posterior predictive checks evaluate whether the model can generate data that look like the observed data. A model can fit parameters well yet still generate unrealistic data; posterior predictive simulation helps detect such model misspecification.

---

12 Add Predictor Variable

---

We now extend the intercept-only model by adding a single predictor: the number of doses beyond the first dose.

This variable is defined as:

\[ x_i = \text{dose\_minus\_1}_i = \text{num\_doses}_i - 1 \]

Using this coding, the intercept \(alpha\) corresponds to the expected log-odds of response for a patient who received exactly one dose. The slope \(beta_{dose}\) represents the change in log-odds of response associated with each additional dose beyond the first.

We begin with a skeptical prior centered at zero for the dose effect, reflecting no strong prior assumption that additional doses improve response.

\[ \begin{aligned} y_i &\sim \text{Bernoulli}(p_i) \\ \text{logit}(p_i) &= \alpha + \beta_{\text{dose}} x_i \\ \alpha &\sim \text{Normal}(\text{logit}(0.40),\,1.5) \\ \beta_{\text{dose}} &\sim \text{Normal}(0,\,0.5) \end{aligned} \]

12.0.1 Step 1: simulate the predictor first

Since we are doing this McElreath-style, we should first simulate x, then simulate y conditional on x.

We already have a realistic dose distribution from your older workflow. We can reuse just that piece.

set.seed(123)

N <- 189

observed_doses <- c(
  rep(1, 11), rep(2, 79), rep(3, 19), rep(4, 18), rep(5, 11),
  rep(6, 9), rep(7, 6), rep(8, 9), rep(9, 5), rep(10, 1),
  rep(11, 3), rep(13, 2), rep(14, 3), rep(15, 2), rep(16, 3),
  rep(20, 1), rep(28, 1), rep(43, 1)
)

d_sim_dose <- tibble(
  patient_id = 1:N,
  num_doses = sample(observed_doses, N, replace = TRUE)
) |>
  mutate(
    dose_minus_1 = num_doses - 1
  )

summary(d_sim_dose$dose_minus_1)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   1.000   1.000   3.481   4.000  42.000 

table(d_sim_dose$num_doses)

 1  2  3  4  5  6  7  8  9 10 11 13 14 15 16 28 43 
10 86 20 17 10  5  6 11  6  3  4  2  4  2  1  1  1 

12.0.2 Step 2: choose the true parameter values

We will keep this very explicit.

alpha_true <- qlogis(0.4)   # baseline response probability at 1 dose
beta_dose_true <- 0.0       # start with null effect

Later we can rerun with beta_dose_true <- 0.15 or 0.20.

12.0.3 Step 3: simulate the outcome

set.seed(123)
d_sim_dose <- d_sim_dose |>
  mutate(
    p = plogis(alpha_true + beta_dose_true * dose_minus_1),  # convert log-odds → probability
    y = rbinom(n(), size = 1, prob = p)                      # simulate Bernoulli outcomes
  )

# Quick sanity checks on simulated outcome
cat("\n--- Simulated Outcome Diagnostics ---\n")

--- Simulated Outcome Diagnostics ---

cat("Number of rows:", nrow(d_sim_dose), "\n")

Number of rows: 189 

cat("Range of y:", paste(range(d_sim_dose$y), collapse = " to "), "\n")

Range of y: 0 to 1 

cat("Mean response rate:", round(mean(d_sim_dose$y), 3), "\n\n")

Mean response rate: 0.386 

cat("Outcome counts:\n")

Outcome counts:

print(table(d_sim_dose$y))

  0   1 
116  73 

Here the predictor is simulated first, then the outcome is generated conditional on that predictor.

The generative order is therefore:

\[ x_i \rightarrow \alpha,\beta \rightarrow p_i \rightarrow y_i \]

More specifically:

1. simulate dose count
2. Compute \(x_i\) = dose_minus_1\(_i\).
3. Choose the true parameter values \(\alpha\) and \(\beta_{\text{dose}}\).
   
4. Compute the response probability \(p_i\).
   
5. Simulate the binary outcome \(y_i\) from \(\text{Bernoulli}(p_i)\).

12.0.4 Step 4: prepare the data list for ulam

alpha_mu <- qlogis(0.4)
beta_dose_mu <- 0

dat_dose <- list(
  N = nrow(d_sim_dose),
  y = d_sim_dose$y,
  x = d_sim_dose$dose_minus_1,
  alpha_mu = alpha_mu,
  beta_dose_mu = beta_dose_mu
)

12.0.5 Step 5: fit the model

Here is the ulam() model with concise comments.

# Note: generative logic runs conceptually bottom -> top:
#   1. alpha is drawn from its prior
#   2. beta_dose is drawn from its prior
#   3. p_i is computed from alpha + beta_dose * x_i
#   4. y_i is generated from Bernoulli(p_i)

m_dose <- ulam(
  alist(
    y ~ bernoulli(p),                           # likelihood: binary response outcome
    logit(p) <- alpha + beta_dose * x,          # linear predictor: intercept + dose effect
    alpha ~ normal(alpha_mu, 1.5),              # prior: baseline log-odds at 1 dose
    beta_dose ~ normal(beta_dose_mu, 0.15)       # prior: skeptical dose effect centered at 0
  ),
  data = dat_dose,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 0.1 seconds.
Chain 2 finished in 0.1 seconds.
Chain 3 finished in 0.1 seconds.
Chain 4 finished in 0.1 seconds.

All 4 chains finished successfully.
Mean chain execution time: 0.1 seconds.
Total execution time: 0.2 seconds.

12.0.6 Step 6: check whether it recovers the truth

precis(m_dose, depth = 2)

                 mean         sd         5.5%      94.5%     rhat ess_bulk
alpha     -0.62955485 0.18539109 -0.930777133 -0.3347473 1.000768 1746.360
beta_dose  0.04649364 0.03345697 -0.005340799  0.1017988 1.000171 1848.774

The true parameter values used to generate the data were:

• \(\alpha_{\text{true}} = \text{logit}(0.40) \approx -0.405\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)

The posterior summary should therefore recover an intercept near \(-0.405\) and a dose effect near \(0\).

12.0.7 Intercept (\(\alpha\))

The intercept represents the log-odds of response for a patient receiving exactly one dose, since the predictor was defined as:

\[ x_i = \text{dose\_minus\_1}_i = \text{num\_doses}_i - 1 \]

The posterior mean is \(\alpha \approx -0.64\).

This corresponds to a response probability of:

\[ \text{logit}^{-1}(-0.64) \approx 0.35 \]

So the model estimates a baseline response probability of roughly 35% at one dose.

12.0.8 Dose Effect (\(\beta_{\text{dose}}\))

The slope parameter represents the change in log-odds of response for each additional dose beyond the first.

Posterior summary:

• mean \(\approx 0.05\)
• 89% CrI \(\approx [0.00,\ 0.11]\)

Converted to the odds ratio scale:

\[ \text{OR} = e^{\beta_{\text{dose}}} \]

Mean effect:

\[ e^{0.05} \approx 1.05 \]

This corresponds to roughly a 5% increase in the odds of response per additional dose.

However, the credible interval includes values close to zero, indicating considerable uncertainty about the magnitude of the dose effect.

12.1 Prior Predictive Check for the Dose Model

Before interpreting the fitted model, it is useful to examine the implications of the priors. In particular, we want to understand what kinds of dose-response relationships are allowed by the prior on \(\beta_{\text{dose}}\) before seeing any data.

To do this, we simulate values of \(\alpha\) and \(\beta_{\text{dose}}\) from their priors, compute the implied response probabilities across a range of dose values, and visualize the resulting prior predictive curves.

12.1.1 Simulate prior dose-response curves

set.seed(123)

n_prior <- 200
dose_grid <- 0:10   # dose_minus_1 scale: 0 = 1 dose, 1 = 2 doses, etc.

prior_draws_dose <- tibble(
  draw = 1:n_prior,
  alpha = rnorm(n_prior, mean = alpha_mu, sd = 1.5),
  beta_dose = rnorm(n_prior, mean = beta_dose_mu, sd = 0.15)
)

prior_curves_dose <- prior_draws_dose |>
  tidyr::crossing(x = dose_grid) |>
  mutate(
    p = plogis(alpha + beta_dose * x),
    num_doses = x + 1
  )

prior_curve_summary_dose <- prior_curves_dose |>
  dplyr::group_by(num_doses) |>
  dplyr::summarise(
    p_median = median(p),
    p_lower_50 = quantile(p, 0.25),
    p_upper_50 = quantile(p, 0.75),
    p_lower_89 = quantile(p, 0.055),
    p_upper_89 = quantile(p, 0.945),
    .groups = "drop"
  )

12.1.2 Plot: prior predictive dose-response curves

ggplot() +

  # spaghetti curves
  geom_line(
    data = prior_curves_dose,
    aes(x = num_doses, y = p, group = draw),
    alpha = 0.08,
    color = "steelblue"
  ) +

  # 89% interval ribbon
  geom_ribbon(
    data = prior_curve_summary_dose,
    aes(x = num_doses, ymin = p_lower_89, ymax = p_upper_89),
    fill = "steelblue",
    alpha = 0.15
  ) +

  # 50% interval ribbon
  geom_ribbon(
    data = prior_curve_summary_dose,
    aes(x = num_doses, ymin = p_lower_50, ymax = p_upper_50),
    fill = "steelblue",
    alpha = 0.30
  ) +

  # median trend line
  geom_line(
    data = prior_curve_summary_dose,
    aes(x = num_doses, y = p_median),
    linewidth = 1.3,
    color = "navy"
  ) +

  scale_y_continuous(limits = c(0, 1)) +

  labs(
    title = "Prior Predictive Dose–Response Curves",
    subtitle = "Skeptical prior (β_dose ~ Normal(0, 0.15))",
    x = "Number of doses",
    y = "Response probability"
  ) +

  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

This plot shows the range of dose-response relationships allowed by the priors before observing any data. The goal is not to make the prior narrowly correct, but to ensure that it allows plausible clinical patterns without concentrating too strongly on unrealistic ones.

The skeptical prior for \(\beta_{\text{dose}}\) is centered at zero and therefore allows both positive and negative dose-response relationships. This produces some prior predictive curves in which response probability decreases with increasing dose.

Although such curves may be less clinically plausible at the population level, this is acceptable for the skeptical prior because its purpose is to serve as a conservative reference that does not assume benefit from additional doses. In contrast, the weakly informative prior may better reflect the substantive belief that the population-level dose effect is more likely to be null or modestly positive than strongly negative.

12.1.3 Then do prior vs posterior for \(\beta_{\text{dose}}\)

This is the next most important thing.

post_dose <- extract.samples(m_dose)

prior_beta_df <- tibble(
  value = rnorm(4000, mean = beta_dose_mu, sd = 0.5),
  source = "Prior"
)

posterior_beta_df <- tibble(
  value = post_dose$beta_dose,
  source = "Posterior"
)

bind_rows(prior_beta_df, posterior_beta_df) |>
  ggplot(aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  geom_vline(xintercept = 0, linetype = "dashed") +
  labs(
    title = "Prior vs Posterior for Dose Effect",
    x = expression(beta[dose]),
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold")
  )

The prior distribution for \(\beta_{\text{dose}}\) was centered at zero, reflecting a skeptical prior belief that additional doses may have little or no effect on response.

After observing the simulated data, the posterior distribution narrows and shifts slightly toward positive values. This indicates that the observed data provide some evidence for a positive dose effect, but the effect remains small and uncertain.

12.1.4 Posterior predictive checks

For the dose model, the best posterior predictive check is not just the overall response rate but also the response pattern across dose groups.

A simple version is:

1. simulate new outcomes from posterior draws

2. compare observed and simulated response rates by dose group

observed_rate <- mean(d_sim_dose$y)

pp_rates_dose <- sapply(seq_along(post_dose$alpha), function(i) {
  p <- plogis(post_dose$alpha[i] + post_dose$beta_dose[i] * dat_dose$x)
  y_rep <- rbinom(dat_dose$N, size = 1, prob = p)
  mean(y_rep)
})

pp_df_dose <- tibble(
  simulated_response_rate = pp_rates_dose
)

ggplot(pp_df_dose, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(xintercept = observed_rate, color = "red", linewidth = 1.2, linetype = "dashed") +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Dose Model",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

12.1.5 Interpretation

The histogram shows the distribution of response rates from datasets simulated under the posterior predictive distribution of the fitted model. Each simulated dataset was generated using posterior draws of the intercept and dose effect parameters.

The red dashed line represents the observed response rate in the simulated dataset used to fit the model.

Because the observed response rate lies near the center of the posterior predictive distribution, the model is capable of generating data consistent with the observed dataset. This indicates that the intercept-plus-dose model provides a reasonable description of the simulated data-generating process.

The width of the posterior predictive distribution largely reflects binomial sampling variability for a dataset of this size. Because the sample size is approximately 189 patients, response rates generated under the model naturally vary by several percentage points across simulated datasets.

---

13 Add a Second Predictor: Age-Centered

---

We now extend the dose model by adding a second predictor: centered age.

Age is centered at 76 years, so that:

\[ \text{age\_centered}_i = \text{age}_i - 76 \]

This centering makes the intercept easier to interpret. Specifically, \(\alpha\) now represents the log-odds of response for a patient who:

• received exactly one dose, and
• is 76 years old

The coefficient \(\beta_{\text{age}}\) represents the change in log-odds of response for each one-year increase in age above 76 years.

13.0.1 Step 1: specify the model mathematically

\[ \begin{aligned} y_i &\sim \text{Bernoulli}(p_i) \\ \text{logit}(p_i) &= \alpha + \beta_{\text{dose}} x_i + \beta_{\text{age}} z_i \\ \alpha &\sim \mathcal{N}(\text{logit}(0.40), 1.5) \\ \beta_{\text{dose}} &\sim \mathcal{N}(0, 0.5) \\ \beta_{\text{age}} &\sim \mathcal{N}(0, 0.02) \end{aligned} \]

where:

• \(x_i = \text{dose\_minus\_1}_i\)
• \(z_i = \text{age\_centered}_i\)

13.0.2 Step 2: simulate the predictors

We simulate dose count and age first, then generate the outcome conditional on those predictors

set.seed(123)

N <- 189

observed_doses <- c(
  rep(1, 11), rep(2, 79), rep(3, 19), rep(4, 18), rep(5, 11),
  rep(6, 9), rep(7, 6), rep(8, 9), rep(9, 5), rep(10, 1),
  rep(11, 3), rep(13, 2), rep(14, 3), rep(15, 2), rep(16, 3),
  rep(20, 1), rep(28, 1), rep(43, 1)
)

d_sim_age <- tibble(
  patient_id = 1:N,
  num_doses = sample(observed_doses, N, replace = TRUE),
  age = rnorm(N, mean = 76, sd = 12)
) |>
  mutate(
    dose_minus_1 = num_doses - 1,
    age_centered = age - 76
  )

The generative order is therefore:

\[ x_i, z_i \rightarrow \alpha, \beta_{\text{dose}}, \beta_{\text{age}} \rightarrow p_i \rightarrow y_i \]

More specifically:

1. Simulate dose count.
2. Compute \(x_i = \text{dose\_minus\_1}_i\).
3. Simulate age.
4. Compute \(z_i = \text{age\_centered}_i\).
5. Choose true parameter values.
6. Compute response probability \(p_i\).
7. Simulate binary outcome \(y_i\) from \(\text{Bernoulli}(p_i)\).

13.1 Step 3: choose the true parameter values

For this simulation, we use:

• \(\alpha_{\text{true}} = \text{logit}(0.40)\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)

This implies that the true baseline response probability is 40% for a 76-year-old patient receiving one dose, with no true dose effect and a small negative age effect.

alpha_true <- qlogis(0.40)
beta_dose_true <- 0
beta_age_true <- -0.01

13.2 Step 4: simulate the outcome

d_sim_age <- d_sim_age |>
  mutate(
    p = plogis(alpha_true +
                 beta_dose_true * dose_minus_1 +
                 beta_age_true * age_centered),
    y = rbinom(n(), size = 1, prob = p)
  )

cat("\n--- Simulated Outcome Diagnostics ---\n")

--- Simulated Outcome Diagnostics ---

cat("Number of rows:", nrow(d_sim_age), "\n")

Number of rows: 189 

cat("Range of y:", paste(range(d_sim_age$y), collapse = " to "), "\n")

Range of y: 0 to 1 

cat("Mean response rate:", round(mean(d_sim_age$y), 3), "\n\n")

Mean response rate: 0.376 

cat("Outcome counts:\n")

Outcome counts:

print(table(d_sim_age$y))

  0   1 
118  71 

13.3 Step 5: fit the model

set.seed(123)

alpha_mu <- qlogis(0.40)
beta_dose_mu <- 0
beta_age_mu <- 0

dat_age <- list(
  N = nrow(d_sim_age),
  y = d_sim_age$y,
  x = d_sim_age$dose_minus_1,
  z = d_sim_age$age_centered,
  alpha_mu = alpha_mu,
  beta_dose_mu = beta_dose_mu,
  beta_age_mu = beta_age_mu
)

# Note: generative logic runs conceptually bottom -> top:
#   1. alpha is drawn from its prior
#   2. beta_dose is drawn from its prior
#   3. beta_age is drawn from its prior
#   4. p_i is computed from alpha + beta_dose * x_i + beta_age * z_i
#   5. y_i is generated from Bernoulli(p_i)

m_age <- ulam(
  alist(
    y ~ bernoulli(p),                                   # likelihood: binary response outcome
    logit(p) <- alpha + beta_dose * x + beta_age * z,  # linear predictor
    alpha ~ normal(alpha_mu, 1.5),                     # prior: baseline log-odds at 1 dose, age 76
    beta_dose ~ normal(beta_dose_mu, 0.5),             # prior: skeptical dose effect
    beta_age ~ normal(beta_age_mu, 0.02)               # prior: skeptical per-year age effect; narrowed because age spans decades, so wider priors produce implausibly large shifts in response
  ),
  data = dat_age,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 0.1 seconds.
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 finished in 0.1 seconds.
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 finished in 0.1 seconds.
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 finished in 0.1 seconds.

All 4 chains finished successfully.
Mean chain execution time: 0.1 seconds.
Total execution time: 0.3 seconds.

The prior for the age effect was tightened from \(\mathcal{N}(0, 0.1)\) to \(\mathcal{N}(0, 0.02)\) because age is modeled on a per-year scale. When a predictor spans several decades, even modest coefficient values can imply very large changes in log-odds across the observed range.

A prior standard deviation of 0.02 still allows age to have a meaningful effect, but avoids prior predictive curves in which age alone drives response probability from near 0 to near 1. This better reflects the substantive belief that age may influence response, but is unlikely to produce dramatic shifts at the population level. ### Step 6: check whether it recovers the truth

precis(m_age, depth = 2)

                 mean         sd        5.5%       94.5%     rhat ess_bulk
alpha     -0.62502879 0.19501817 -0.93497505 -0.31669000 1.002499 2173.305
beta_dose  0.03133486 0.03378742 -0.02031515  0.08504474 1.002212 2259.378
beta_age  -0.00417305 0.01007588 -0.02032033  0.01177773 1.002590 2733.773

The true parameter values used to generate the data were:

• \(\alpha_{\text{true}} = \text{logit}(0.40) \approx -0.405\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)

The posterior summary should therefore recover:

• an intercept near \(-0.405\)
• a dose effect near \(0\)
• an age effect near \(-0.01\)

13.4 Step 7: prior predictive check for age

To understand what the priors imply before seeing any data, we simulate prior predictive response curves across age while holding dose fixed at one dose (that is, \(x_i = 0\)).

set.seed(123)

n_prior <- 200
age_grid <- seq(-30, 30, by = 1)  # centered age: 46 to 106 years

prior_draws_age <- tibble(
  draw = 1:n_prior,
  alpha = rnorm(n_prior, mean = alpha_mu, sd = 1.5),
  beta_age = rnorm(n_prior, mean = beta_age_mu, sd = 0.02)
)

prior_curves_age <- prior_draws_age |>
  tidyr::crossing(z = age_grid) |>
  mutate(
    p = plogis(alpha + beta_age * z),   # dose held fixed at x = 0
    age = z + 76
  )

ggplot(prior_curves_age,
       aes(x = age, y = p, group = draw)) +
  geom_line(alpha = 0.15, color = "steelblue") +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Prior Predictive Age-Response Curves",
    subtitle = "Dose fixed at one dose",
    x = "Age (years)",
    y = "Response probability"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

This plot shows the range of age-response relationships allowed by the priors before observing any data. Because the prior for \(\beta_{\text{age}}\) is centered at zero, the prior predictive curves allow both positive and negative age effects, although extreme slopes should remain uncommon.

Fan Plot for age prior predictive simulation

# age grid
age_grid <- seq(46, 106, length.out = 100)
z <- age_grid - 76

# simulate prior draws
n_draws <- 2000

prior_draws <- tibble(
  alpha = rnorm(n_draws, alpha_mu, 1.5),
  beta_age = rnorm(n_draws, beta_age_mu, 0.02)
)

# compute predicted probabilities
fan_df <- expand_grid(
  draw = 1:n_draws,
  age = age_grid
) |>
  mutate(
    z = age - 76,
    alpha = prior_draws$alpha[draw],
    beta_age = prior_draws$beta_age[draw],
    p = plogis(alpha + beta_age * z)
  )

fan_quantiles <- fan_df |>
  group_by(age) |>
  summarise(
    p50 = median(p),
    p80_lo = quantile(p, 0.10),
    p80_hi = quantile(p, 0.90),
    p95_lo = quantile(p, 0.025),
    p95_hi = quantile(p, 0.975)
  )

ggplot(fan_quantiles, aes(x = age)) +

  geom_ribbon(aes(ymin = p95_lo, ymax = p95_hi),
              fill = "steelblue", alpha = 0.15) +

  geom_ribbon(aes(ymin = p80_lo, ymax = p80_hi),
              fill = "steelblue", alpha = 0.35) +

  geom_line(aes(y = p50), linewidth = 1.3, color = "black") +

  labs(
    title = "Prior Predictive Age–Response Fan Plot",
    subtitle = "Dose fixed at one dose",
    x = "Age (years)",
    y = "Response probability"
  ) +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

13.5 Step 8: prior vs posterior for the age effect

post_age <- extract.samples(m_age)

prior_beta_age_df <- tibble(
  value = rnorm(4000, mean = beta_age_mu, sd = 0.1),
  source = "Prior"
)

posterior_beta_age_df <- tibble(
  value = post_age$beta_age,
  source = "Posterior"
)

beta_age_plot_df <- bind_rows(
  prior_beta_age_df,
  posterior_beta_age_df
)

ggplot(beta_age_plot_df, aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  geom_vline(xintercept = 0, linetype = "dashed") +
  labs(
    title = "Prior vs Posterior for Age Effect",
    x = expression(beta[age]),
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold")
  )

The prior distribution for \(\beta_{\text{age}}\) is centered at zero, reflecting a skeptical prior belief that age may have little effect on response. After observing the simulated data, the posterior distribution should narrow around the true value used to generate the data.

13.6 Step 9: posterior predictive check

observed_rate_age <- mean(d_sim_age$y)

pp_rates_age <- sapply(seq_along(post_age$alpha), function(i) {
  p <- plogis(post_age$alpha[i] +
                post_age$beta_dose[i] * dat_age$x +
                post_age$beta_age[i] * dat_age$z)
  y_rep <- rbinom(dat_age$N, size = 1, prob = p)
  mean(y_rep)
})

pp_df_age <- tibble(
  simulated_response_rate = pp_rates_age
)

ggplot(pp_df_age, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(xintercept = observed_rate_age, color = "red", linewidth = 1.2, linetype = "dashed") +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Age Model",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

The histogram shows the distribution of response rates from datasets simulated under the posterior predictive distribution of the fitted model. The red dashed line indicates the observed response rate in the simulated dataset used to fit the model.

If the observed response rate lies comfortably within the center of the posterior predictive distribution, this suggests that the model can plausibly generate datasets like the one observed.

---

14 Add a Third Predictor: Immunosuppressed

---

We now extend the model by adding a binary predictor for immunosuppression.

Let:

• \(\text{immunosuppressed}_i = 1\) if the patient is immunosuppressed
• \(\text{immunosuppressed}_i = 0\) otherwise

The coefficient \(\beta_{\text{imm}}\) represents the change in log-odds of response for immunosuppressed patients relative to non-immunosuppressed patients, holding dose and age constant.

Because this is a binary variable, the coefficient is interpreted as a between-group shift rather than a per-unit slope.

14.1 Step 1: specify the model mathematically

\[ \begin{aligned} y_i &\sim \text{Bernoulli}(p_i) \\ \text{logit}(p_i) &= \alpha + \beta_{\text{dose}} x_i + \beta_{\text{age}} z_i + \beta_{\text{imm}} w_i \\ \alpha &\sim \mathcal{N}(\text{logit}(0.40), 1.5) \\ \beta_{\text{dose}} &\sim \mathcal{N}(0, 0.5) \\ \beta_{\text{age}} &\sim \mathcal{N}(0, 0.02) \\ \beta_{\text{imm}} &\sim \mathcal{N}(-0.6, 0.2) \end{aligned} \]

where:

• \(x_i = \text{dose\_minus\_1}_i\)
• \(z_i = \text{age\_centered}_i\)
• \(w_i = \text{immunosuppressed}_i\)

14.2 Step 2: simulate the predictors

We now simulate dose, age, and immunosuppression status before generating the outcome.

set.seed(123)

N <- 189

observed_doses <- c(
  rep(1, 11), rep(2, 79), rep(3, 19), rep(4, 18), rep(5, 11),
  rep(6, 9), rep(7, 6), rep(8, 9), rep(9, 5), rep(10, 1),
  rep(11, 3), rep(13, 2), rep(14, 3), rep(15, 2), rep(16, 3),
  rep(20, 1), rep(28, 1), rep(43, 1)
)

d_sim_imm <- tibble(
  patient_id = 1:N,
  num_doses = sample(observed_doses, N, replace = TRUE),
  age = rnorm(N, mean = 76, sd = 12),
  immunosuppressed = rbinom(N, size = 1, prob = 0.17)
) |>
  mutate(
    dose_minus_1 = num_doses - 1,
    age_centered = age - 76
  )

The generative order is therefore:

\[ x_i, z_i, w_i \rightarrow \alpha, \beta_{\text{dose}}, \beta_{\text{age}}, \beta_{\text{imm}} \rightarrow p_i \rightarrow y_i \]

More specifically:

1. Simulate dose count.
2. Compute \(x_i = \text{dose\_minus\_1}_i\).
3. Simulate age.
4. Compute \(z_i = \text{age\_centered}_i\).
5. Simulate immunosuppression status \(w_i\).
6. Choose true parameter values.
7. Compute response probability \(p_i\).
8. Simulate binary outcome \(y_i\) from \(\text{Bernoulli}(p_i)\).

14.3 Step 3: choose the true parameter values

For this simulation, we use:

• \(\alpha_{\text{true}} = \text{logit}(0.40)\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)
• \(\beta_{\text{imm}}^{\text{true}} = -0.8\)

This implies that immunosuppression lowers the log-odds of response, holding other predictors constant.

alpha_true <- qlogis(0.40)
beta_dose_true <- 0
beta_age_true <- -0.01
beta_imm_true <- -0.8

14.4 Step 4: simulate the outcome

d_sim_imm <- d_sim_imm |>
  mutate(
    p = plogis(
      alpha_true +
        beta_dose_true * dose_minus_1 +
        beta_age_true * age_centered +
        beta_imm_true * immunosuppressed
    ),
    y = rbinom(n(), size = 1, prob = p)
  )

cat("\n--- Simulated Outcome Diagnostics ---\n")

--- Simulated Outcome Diagnostics ---

cat("Number of rows:", nrow(d_sim_imm), "\n")

Number of rows: 189 

cat("Range of y:", paste(range(d_sim_imm$y), collapse = " to "), "\n")

Range of y: 0 to 1 

cat("Mean response rate:", round(mean(d_sim_imm$y), 3), "\n\n")

Mean response rate: 0.386 

cat("Outcome counts:\n")

Outcome counts:

print(table(d_sim_imm$y))

  0   1 
116  73 

cat("\nImmunosuppression counts:\n")

Immunosuppression counts:

print(table(d_sim_imm$immunosuppressed))

  0   1 
164  25 

14.5 Step 5: fit the model

alpha_mu <- qlogis(0.40)
beta_dose_mu <- 0
beta_age_mu <- 0
beta_imm_mu <- -0.8

dat_imm <- list(
  N = nrow(d_sim_imm),
  y = d_sim_imm$y,
  x = d_sim_imm$dose_minus_1,
  z = d_sim_imm$age_centered,
  w = d_sim_imm$immunosuppressed,
  alpha_mu = alpha_mu,
  beta_dose_mu = beta_dose_mu,
  beta_age_mu = beta_age_mu,
  beta_imm_mu = beta_imm_mu
)

# Note: generative logic runs conceptually bottom -> top:
#   1. alpha is drawn from its prior
#   2. beta_dose is drawn from its prior
#   3. beta_age is drawn from its prior
#   4. beta_imm is drawn from its prior
#   5. p_i is computed from alpha + beta_dose*x_i + beta_age*z_i + beta_imm*w_i
#   6. y_i is generated from Bernoulli(p_i)

m_imm <- ulam(
  alist(
    y ~ bernoulli(p),                                      # likelihood: binary response outcome
    logit(p) <- alpha + beta_dose * x + beta_age * z + beta_imm * w,  # linear predictor
    alpha ~ normal(alpha_mu, 1.5),                         # prior: baseline log-odds at 1 dose, age 76, non-immunosuppressed
    beta_dose ~ normal(beta_dose_mu, 0.5),                # prior: skeptical dose effect
    beta_age ~ normal(beta_age_mu, 0.02),                 # prior: skeptical per-year age effect
    beta_imm ~ normal(beta_imm_mu, 0.2)                   # prior: immunosuppression expected to reduce response
  ),
  data = dat_imm,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 0.2 seconds.
Chain 2 finished in 0.2 seconds.
Chain 3 finished in 0.2 seconds.
Chain 4 finished in 0.2 seconds.

All 4 chains finished successfully.
Mean chain execution time: 0.2 seconds.
Total execution time: 0.3 seconds.

14.6 Step 6: check whether it recovers the truth

precis(m_imm, depth = 2)

                  mean         sd        5.5%       94.5%     rhat ess_bulk
alpha     -0.454522379 0.19051535 -0.76443355 -0.15501819 1.000700 3059.096
beta_dose  0.020868978 0.03373202 -0.03224793  0.07554859 1.001108 2813.701
beta_age  -0.005695548 0.01017157 -0.02211878  0.01040532 1.001202 4424.359
beta_imm  -0.769059733 0.18181164 -1.06398746 -0.48269673 1.000008 4148.028

The true parameter values used to generate the data were:

• \(\alpha_{\text{true}} = \text{logit}(0.40) \approx -0.405\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)
• \(\beta_{\text{imm}}^{\text{true}} = -0.8\)

The posterior summary should therefore recover:

• an intercept near \(-0.405\)
• a dose effect near \(0\)
• an age effect near \(-0.01\)
• an immunosuppression effect near \(-0.8\)

14.7 Step 7: prior predictive check for immunosuppression

For a binary variable like immunosuppression, a fan plot is less useful than a grouped interval plot. Here we compare the prior predictive response probability for:

• non-immunosuppressed patients (\(w_i = 0\))
• immunosuppressed patients (\(w_i = 1\))

while holding dose fixed at one dose and age fixed at 76 years.

set.seed(123)

n_prior <- 4000

prior_draws_imm <- tibble(
  alpha = rnorm(n_prior, mean = alpha_mu, sd = 1.5),
  beta_imm = rnorm(n_prior, mean = beta_imm_mu, sd = 0.2)
) |>
  mutate(
    p_nonimm = plogis(alpha),
    p_imm = plogis(alpha + beta_imm)
  )

prior_imm_long <- bind_rows(
  prior_draws_imm |>
    transmute(group = "Not immunosuppressed", p = p_nonimm),
  prior_draws_imm |>
    transmute(group = "Immunosuppressed", p = p_imm)
)

ggplot(prior_imm_long |> mutate(group = factor(group,
       levels = c("Not immunosuppressed", "Immunosuppressed"))), aes(x = group, y = p, fill = group)) +
  geom_violin(alpha = 0.5, width = 0.9, color = NA) +
  stat_summary(fun = median, geom = "point", size = 2, color = "black") +
  stat_summary(fun.data = median_hilow, fun.args = list(conf.int = 0.8),
               geom = "errorbar", width = 0.15, linewidth = 0.8, color = "black") +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Prior Predictive Response by Immunosuppression Status",
    subtitle = "Dose fixed at one dose; age fixed at 76 years",
    x = NULL,
    y = "Response probability"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    legend.position = "none"
  )

This plot shows the prior predictive response distributions for immunosuppressed and non-immunosuppressed patients before seeing any data. Because the prior for \(\beta_{\text{imm}}\) is centered below zero, the model expresses a prior belief that immunosuppression lowers the probability of response.

14.8 Step 8: prior vs posterior for the immunosuppression effect

post_imm <- extract.samples(m_imm)

prior_beta_imm_df <- tibble(
  value = rnorm(4000, mean = beta_imm_mu, sd = 0.2),
  source = "Prior"
)

posterior_beta_imm_df <- tibble(
  value = post_imm$beta_imm,
  source = "Posterior"
)

beta_imm_plot_df <- bind_rows(
  prior_beta_imm_df,
  posterior_beta_imm_df
)

ggplot(beta_imm_plot_df, aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  geom_vline(xintercept = 0, linetype = "dashed") +
  labs(
    title = "Prior vs Posterior for Immunosuppression Effect",
    x = expression(beta[imm]),
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold")
  )

14.9 Step 9: posterior predictive check

observed_rate_imm <- mean(d_sim_imm$y)

pp_rates_imm <- sapply(seq_along(post_imm$alpha), function(i) {
  p <- plogis(
    post_imm$alpha[i] +
      post_imm$beta_dose[i] * dat_imm$x +
      post_imm$beta_age[i] * dat_imm$z +
      post_imm$beta_imm[i] * dat_imm$w
  )
  y_rep <- rbinom(dat_imm$N, size = 1, prob = p)
  mean(y_rep)
})

pp_df_imm <- tibble(
  simulated_response_rate = pp_rates_imm
)

ggplot(pp_df_imm, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(xintercept = observed_rate_imm, color = "red", linewidth = 1.2, linetype = "dashed") +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Immunosuppression Model",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

The histogram shows the distribution of response rates from datasets simulated under the posterior predictive distribution of the fitted model. If the observed response rate lies comfortably within this distribution, the model is capable of generating data similar to those observed.

---

15 Add a Fourth Predictor: Location (Condensed)

---

We now extend the model by adding a multi-level categorical predictor for tumor location.

The condensed location variable has four levels:

• Head/Neck (reference)
• Conjunctiva
• Other
• Unknown Primary

Using Head/Neck as the reference category, the model estimates separate log-odds shifts for the other location groups.

This is the first categorical predictor with more than two levels, so the model now includes multiple indicator coefficients rather than a single slope.

15.1 Step 1: specify the model mathematically

\[ \begin{aligned} y_i &\sim \text{Bernoulli}(p_i) \\ \text{logit}(p_i) &= \alpha + \beta_{\text{dose}} x_i + \beta_{\text{age}} z_i + \beta_{\text{imm}} w_i + \beta_{\text{conj}} c_i + \beta_{\text{other}} o_i + \beta_{\text{unknown}} u_i \\ \alpha &\sim \mathcal{N}(\text{logit}(0.40), 1.5) \\ \beta_{\text{dose}} &\sim \mathcal{N}(0, 0.5) \\ \beta_{\text{age}} &\sim \mathcal{N}(0, 0.02) \\ \beta_{\text{imm}} &\sim \mathcal{N}(-0.8, 0.2) \\ \beta_{\text{conj}} &\sim \mathcal{N}(-2.3, 0.5) \\ \beta_{\text{other}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{unknown}} &\sim \mathcal{N}(0, 0.3) \end{aligned} \]

where:

• \(x_i = \text{dose\_minus\_1}_i\)
• \(z_i = \text{age\_centered}_i\)
• \(w_i = \text{immunosuppressed}_i\)
• \(c_i = 1\) if location is Conjunctiva, else 0
• \(o_i = 1\) if location is Other, else 0
• \(u_i = 1\) if location is Unknown Primary, else 0

15.2 Step 2: simulate the predictors

We now simulate dose, age, immunosuppression, and location before generating the outcome.

set.seed(123)

N <- 189

observed_doses <- c(
  rep(1, 11), rep(2, 79), rep(3, 19), rep(4, 18), rep(5, 11),
  rep(6, 9), rep(7, 6), rep(8, 9), rep(9, 5), rep(10, 1),
  rep(11, 3), rep(13, 2), rep(14, 3), rep(15, 2), rep(16, 3),
  rep(20, 1), rep(28, 1), rep(43, 1)
)

d_sim_loc <- tibble(
  patient_id = 1:N,
  num_doses = sample(observed_doses, N, replace = TRUE),
  age = rnorm(N, mean = 76, sd = 12),
  immunosuppressed = rbinom(N, size = 1, prob = 0.17),
  location_condensed = sample(
    c("Head/Neck", "Conjunctiva", "Other", "Unknown Primary"),
    N,
    replace = TRUE,
    prob = c(0.80, 0.08, 0.08, 0.04)
  )
) |>
  mutate(
    dose_minus_1 = num_doses - 1,
    age_centered = age - 76,
    loc_conj = as.integer(location_condensed == "Conjunctiva"),
    loc_other = as.integer(location_condensed == "Other"),
    loc_unknown = as.integer(location_condensed == "Unknown Primary")
  )

The generative order is therefore:

\[ x_i, z_i, w_i, c_i, o_i, u_i \rightarrow \alpha, \beta \rightarrow p_i \rightarrow y_i \]

More specifically:

1. Simulate dose count.
2. Compute \(x_i = \text{dose\_minus\_1}_i\).
3. Simulate age.
4. Compute \(z_i = \text{age\_centered}_i\).
5. Simulate immunosuppression status \(w_i\).
6. Simulate condensed location and convert it to indicator variables.
7. Choose true parameter values.
8. Compute response probability \(p_i\).
9. Simulate binary outcome \(y_i\) from \(\text{Bernoulli}(p_i)\).

15.3 Step 3: choose the true parameter values

For this simulation, we use:

• \(\alpha_{\text{true}} = \text{logit}(0.40)\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)
• \(\beta_{\text{imm}}^{\text{true}} = -0.8\)
• \(\beta_{\text{conj}}^{\text{true}} = -2.3\)
• \(\beta_{\text{other}}^{\text{true}} = 0\)
• \(\beta_{\text{unknown}}^{\text{true}} = 0\)

This implies that, relative to Head/Neck, Conjunctiva has a substantially lower response probability, while the Other and Unknown Primary groups do not differ systematically from the reference group.

alpha_true <- qlogis(0.40)
beta_dose_true <- 0
beta_age_true <- -0.01
beta_imm_true <- -0.8
beta_conj_true <- -2.3
beta_other_true <- 0
beta_unknown_true <- 0

15.4 Step 4: simulate the outcome

d_sim_loc <- d_sim_loc |>
  mutate(
    p = plogis(
      alpha_true +
        beta_dose_true * dose_minus_1 +
        beta_age_true * age_centered +
        beta_imm_true * immunosuppressed +
        beta_conj_true * loc_conj +
        beta_other_true * loc_other +
        beta_unknown_true * loc_unknown
    ),
    y = rbinom(n(), size = 1, prob = p)
  )

cat("\n--- Simulated Outcome Diagnostics ---\n")

--- Simulated Outcome Diagnostics ---

cat("Number of rows:", nrow(d_sim_loc), "\n")

Number of rows: 189 

cat("Range of y:", paste(range(d_sim_loc$y), collapse = " to "), "\n")

Range of y: 0 to 1 

cat("Mean response rate:", round(mean(d_sim_loc$y), 3), "\n\n")

Mean response rate: 0.312 

cat("Outcome counts:\n")

Outcome counts:

print(table(d_sim_loc$y))

  0   1 
130  59 

cat("\nLocation counts:\n")

Location counts:

print(table(d_sim_loc$location_condensed))

    Conjunctiva       Head/Neck           Other Unknown Primary 
             16             156              13               4 

15.5 Step 5: fit the model

alpha_mu <- qlogis(0.40)
beta_dose_mu <- 0
beta_age_mu <- 0
beta_imm_mu <- -0.8
beta_conj_mu <- -2.3
beta_other_mu <- 0
beta_unknown_mu <- 0

dat_loc <- list(
  N = nrow(d_sim_loc),
  y = d_sim_loc$y,
  x = d_sim_loc$dose_minus_1,
  z = d_sim_loc$age_centered,
  w = d_sim_loc$immunosuppressed,
  loc_conj = d_sim_loc$loc_conj,
  loc_other = d_sim_loc$loc_other,
  loc_unknown = d_sim_loc$loc_unknown,
  alpha_mu = alpha_mu,
  beta_dose_mu = beta_dose_mu,
  beta_age_mu = beta_age_mu,
  beta_imm_mu = beta_imm_mu,
  beta_conj_mu = beta_conj_mu,
  beta_other_mu = beta_other_mu,
  beta_unknown_mu = beta_unknown_mu
)

# Note: generative logic runs conceptually bottom -> top:
#   1. Draw parameters from priors
#   2. Compute logit(p_i) from predictors and coefficients
#   3. Convert log-odds to probabilities
#   4. Generate y_i from Bernoulli(p_i)

m_loc <- ulam(
  alist(
    y ~ bernoulli(p),  # likelihood: binary response outcome
    
    logit(p) <- alpha +
      beta_dose * x +
      beta_age * z +
      beta_imm * w +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown,  # linear predictor
    
    alpha ~ normal(alpha_mu, 1.5),              # prior: baseline log-odds at 1 dose, age 76, not immunosuppressed, Head/Neck
    beta_dose ~ normal(beta_dose_mu, 0.5),      # prior: skeptical dose effect
    beta_age ~ normal(beta_age_mu, 0.02),       # prior: skeptical per-year age effect
    beta_imm ~ normal(beta_imm_mu, 0.2),        # prior: immunosuppression lowers response
    beta_conj ~ normal(beta_conj_mu, 0.5),      # prior: conjunctiva lower response than Head/Neck
    beta_other ~ normal(beta_other_mu, 0.3),    # prior: other locations near reference
    beta_unknown ~ normal(beta_unknown_mu, 0.3) # prior: unknown primary near reference
  ),
  data = dat_loc,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 finished in 0.3 seconds.
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 0.4 seconds.
Chain 2 finished in 0.4 seconds.
Chain 4 finished in 0.4 seconds.

All 4 chains finished successfully.
Mean chain execution time: 0.4 seconds.
Total execution time: 0.5 seconds.

15.6 Step 6: check whether it recovers the truth

precis(m_loc, depth = 2)

                     mean         sd        5.5%        94.5%     rhat ess_bulk
alpha        -0.578944724 0.20970684 -0.91441967 -0.249463976 1.001829 2952.536
beta_dose    -0.008918915 0.03710001 -0.07071246  0.049199831 1.000598 3039.107
beta_age     -0.014105063 0.01056810 -0.03111766  0.002765294 1.001496 5172.668
beta_imm     -0.831789378 0.19511664 -1.14325697 -0.519634398 1.001195 4397.872
beta_conj    -2.263504455 0.45618029 -2.99631346 -1.544334133 1.000003 4265.081
beta_other   -0.023751120 0.26939402 -0.44646887  0.406570905 1.002594 4231.660
beta_unknown -0.024286628 0.28833288 -0.48812976  0.451158702 1.000181 4292.106

The true parameter values used to generate the data were:

• \(\alpha_{\text{true}} = \text{logit}(0.40) \approx -0.405\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)
• \(\beta_{\text{imm}}^{\text{true}} = -0.8\)
• \(\beta_{\text{conj}}^{\text{true}} = -2.3\)
• \(\beta_{\text{other}}^{\text{true}} = 0\)
• \(\beta_{\text{unknown}}^{\text{true}} = 0\)

The posterior summary should therefore recover values near those targets, with more uncertainty expected for the rare location groups.

15.7 Step 7: prior predictive check for location

For a multi-level categorical predictor, a grouped prior predictive plot is more informative than a fan plot. Here we compare the prior predictive response probability across the four location groups while holding dose fixed at one dose, age fixed at 76 years, and immunosuppression fixed at 0.

set.seed(123)

n_prior <- 4000

prior_draws_loc <- tibble(
  alpha = rnorm(n_prior, mean = alpha_mu, sd = 1.5),
  beta_conj = rnorm(n_prior, mean = beta_conj_mu, sd = 0.5),
  beta_other = rnorm(n_prior, mean = beta_other_mu, sd = 0.3),
  beta_unknown = rnorm(n_prior, mean = beta_unknown_mu, sd = 0.3)
) |>
  mutate(
    p_headneck = plogis(alpha),
    p_conj = plogis(alpha + beta_conj),
    p_other = plogis(alpha + beta_other),
    p_unknown = plogis(alpha + beta_unknown)
  )

prior_loc_long <- bind_rows(
  prior_draws_loc |> transmute(group = "Head/Neck", p = p_headneck),
  prior_draws_loc |> transmute(group = "Conjunctiva", p = p_conj),
  prior_draws_loc |> transmute(group = "Other", p = p_other),
  prior_draws_loc |> transmute(group = "Unknown Primary", p = p_unknown)
) |>
  mutate(
    group = factor(group, levels = c("Head/Neck", "Conjunctiva", "Other", "Unknown Primary"))
  )

ggplot(prior_loc_long, aes(x = group, y = p, fill = group)) +
  geom_violin(alpha = 0.5, width = 0.9, color = NA) +
  stat_summary(fun = median, geom = "point", size = 2, color = "black") +
  stat_summary(
    fun.data = median_hilow,
    fun.args = list(conf.int = 0.8),
    geom = "errorbar",
    width = 0.15,
    linewidth = 0.8,
    color = "black"
  ) +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Prior Predictive Response by Location",
    subtitle = "Dose fixed at one dose; age fixed at 76 years; not immunosuppressed",
    x = NULL,
    y = "Response probability"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    legend.position = "none"
  )

This plot shows the prior predictive response distributions for each location group before seeing any data. Relative to Head/Neck, the Conjunctiva group is expected to have a substantially lower response probability, while the Other and Unknown Primary groups are centered closer to the reference group.

15.8 Step 8: prior vs posterior for the location effects

post_loc <- extract.samples(m_loc)

plot_df_conj <- bind_rows(
  tibble(value = rnorm(4000, beta_conj_mu, 0.5), source = "Prior", term = "Conjunctiva"),
  tibble(value = post_loc$beta_conj, source = "Posterior", term = "Conjunctiva")
)

plot_df_other <- bind_rows(
  tibble(value = rnorm(4000, beta_other_mu, 0.3), source = "Prior", term = "Other"),
  tibble(value = post_loc$beta_other, source = "Posterior", term = "Other")
)

plot_df_unknown <- bind_rows(
  tibble(value = rnorm(4000, beta_unknown_mu, 0.3), source = "Prior", term = "Unknown Primary"),
  tibble(value = post_loc$beta_unknown, source = "Posterior", term = "Unknown Primary")
)

plot_df_loc <- bind_rows(plot_df_conj, plot_df_other, plot_df_unknown)

ggplot(plot_df_loc, aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  facet_wrap(~ term, scales = "free") +
  geom_vline(xintercept = 0, linetype = "dashed") +
  labs(
    title = "Prior vs Posterior for Location Effects",
    x = "Coefficient value",
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold")
  )

These panels compare the prior and posterior distributions for the three non-reference location effects. The posterior distributions show how much the simulated data update the prior beliefs for each location category.

15.9 Step 9: posterior predictive check

observed_rate_loc <- mean(d_sim_loc$y)

pp_rates_loc <- sapply(seq_along(post_loc$alpha), function(i) {
  
  eta <- post_loc$alpha[i] +
    post_loc$beta_dose[i] * dat_loc$x +
    post_loc$beta_age[i] * dat_loc$z +
    post_loc$beta_imm[i] * dat_loc$w +
    post_loc$beta_conj[i] * dat_loc$loc_conj +
    post_loc$beta_other[i] * dat_loc$loc_other +
    post_loc$beta_unknown[i] * dat_loc$loc_unknown
  
  p <- plogis(eta)
  
  y_rep <- rbinom(dat_loc$N, size = 1, prob = p)
  mean(y_rep)
})

summary(pp_rates_loc)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
 0.1534  0.2804  0.3122  0.3127  0.3439  0.4656 

sum(is.na(pp_rates_loc))

[1] 0

range(pp_rates_loc, na.rm = TRUE)

[1] 0.1534392 0.4656085

pp_df_loc <- tibble(
  simulated_response_rate = pp_rates_loc
)

ggplot(pp_df_loc, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(xintercept = observed_rate_loc, color = "red", linewidth = 1.2, linetype = "dashed") +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Location Model",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

---

16 Add a Fifth Predictor: Stage (Condensed)

---

We now extend the model by adding a multi-level categorical predictor for stage.

The condensed stage variable has four levels:

• Stage I-II (reference)
• Stage III
• Stage IV
• Unstaged

Using Stage I-II as the reference category, the model estimates separate log-odds shifts for Stage III, Stage IV, and Unstaged.

As with location, this predictor is represented by multiple indicator coefficients rather than a single slope.

16.1 Step 1: specify the model mathematically

\[ \begin{aligned} y_i &\sim \text{Bernoulli}(p_i) \\ \text{logit}(p_i) &= \alpha + \beta_{\text{dose}} x_i + \beta_{\text{age}} z_i + \beta_{\text{imm}} w_i + \beta_{\text{conj}} c_i + \beta_{\text{other}} o_i + \beta_{\text{unknown}} u_i \\ &\quad + \beta_{\text{III}} s_{III,i} + \beta_{\text{IV}} s_{IV,i} + \beta_{\text{unstaged}} s_{U,i} \\ \alpha &\sim \mathcal{N}(\text{logit}(0.40), 1.5) \\ \beta_{\text{dose}} &\sim \mathcal{N}(0, 0.5) \\ \beta_{\text{age}} &\sim \mathcal{N}(0, 0.02) \\ \beta_{\text{imm}} &\sim \mathcal{N}(-0.8, 0.2) \\ \beta_{\text{conj}} &\sim \mathcal{N}(-2.3, 0.5) \\ \beta_{\text{other}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{unknown}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{III}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{IV}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{unstaged}} &\sim \mathcal{N}(0, 0.3) \end{aligned} \]

where:

• \(x_i = \text{dose\_minus\_1}_i\)
• \(z_i = \text{age\_centered}_i\)
• \(w_i = \text{immunosuppressed}_i\)
• \(c_i = 1\) if location is Conjunctiva, else 0
• \(o_i = 1\) if location is Other, else 0
• \(u_i = 1\) if location is Unknown Primary, else 0
• \(s_{III,i} = 1\) if stage is Stage III, else 0
• \(s_{IV,i} = 1\) if stage is Stage IV, else 0
• \(s_{U,i} = 1\) if stage is Unstaged, else 0

16.2 Step 2: simulate the predictors

We now simulate dose, age, immunosuppression, location, and stage before generating the outcome.

set.seed(123)

N <- 189

observed_doses <- c(
  rep(1, 11), rep(2, 79), rep(3, 19), rep(4, 18), rep(5, 11),
  rep(6, 9), rep(7, 6), rep(8, 9), rep(9, 5), rep(10, 1),
  rep(11, 3), rep(13, 2), rep(14, 3), rep(15, 2), rep(16, 3),
  rep(20, 1), rep(28, 1), rep(43, 1)
)

d_sim_stage <- tibble(
  patient_id = 1:N,
  num_doses = sample(observed_doses, N, replace = TRUE),
  age = rnorm(N, mean = 76, sd = 12),
  immunosuppressed = rbinom(N, size = 1, prob = 0.17),
  location_condensed = sample(
    c("Head/Neck", "Conjunctiva", "Other", "Unknown Primary"),
    N,
    replace = TRUE,
    prob = c(0.80, 0.08, 0.08, 0.04)
  )
) |>
  mutate(
    dose_minus_1 = num_doses - 1,
    age_centered = age - 76,
    loc_conj = as.integer(location_condensed == "Conjunctiva"),
    loc_other = as.integer(location_condensed == "Other"),
    loc_unknown = as.integer(location_condensed == "Unknown Primary")
  ) |>
  rowwise() |>
  mutate(
    stage_condensed = if_else(
      location_condensed == "Conjunctiva",
      sample(c("Stage III", "Stage IV", "Unstaged"), 1, prob = c(0.30, 0.50, 0.20)),
      sample(c("Stage I-II", "Stage III", "Stage IV", "Unstaged"), 1,
             prob = c(0.04, 0.40, 0.45, 0.11))
    )
  ) |>
  ungroup() |>
  mutate(
    stage_III = as.integer(stage_condensed == "Stage III"),
    stage_IV = as.integer(stage_condensed == "Stage IV"),
    stage_unstaged = as.integer(stage_condensed == "Unstaged")
  )

The generative order is therefore:

\[ x_i, z_i, w_i, c_i, o_i, u_i, s_{III,i}, s_{IV,i}, s_{U,i} \rightarrow \alpha, \beta \rightarrow p_i \rightarrow y_i \]

More specifically:

1. Simulate dose count.
2. Compute \(x_i = \text{dose\_minus\_1}_i\).
3. Simulate age.
4. Compute \(z_i = \text{age\_centered}_i\).
5. Simulate immunosuppression status \(w_i\).
6. Simulate condensed location and convert it to indicator variables.
7. Simulate condensed stage and convert it to indicator variables.
8. Choose true parameter values.
9. Compute response probability \(p_i\) and simulate binary outcome \(y_i\).

16.3 Step 3: choose the true parameter values

For this simulation, we use:

• \(\alpha_{\text{true}} = \text{logit}(0.40)\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)
• \(\beta_{\text{imm}}^{\text{true}} = -0.8\)
• \(\beta_{\text{conj}}^{\text{true}} = -2.3\)
• \(\beta_{\text{other}}^{\text{true}} = 0\)
• \(\beta_{\text{unknown}}^{\text{true}} = 0\)
• \(\beta_{\text{III}}^{\text{true}} = 0\)
• \(\beta_{\text{IV}}^{\text{true}} = 0\)
• \(\beta_{\text{unstaged}}^{\text{true}} = 0\)

This means stage is included in the model but, under the skeptical simulation scenario, does not have an additional independent effect on response.

alpha_true <- qlogis(0.40)
beta_dose_true <- 0
beta_age_true <- -0.01
beta_imm_true <- -0.8
beta_conj_true <- -2.3
beta_other_true <- 0
beta_unknown_true <- 0
beta_stage_III_true <- 0
beta_stage_IV_true <- 0
beta_stage_unstaged_true <- 0

16.4 Step 4: simulate the outcome

d_sim_stage <- d_sim_stage |>
  mutate(
    p = plogis(
      alpha_true +
        beta_dose_true * dose_minus_1 +
        beta_age_true * age_centered +
        beta_imm_true * immunosuppressed +
        beta_conj_true * loc_conj +
        beta_other_true * loc_other +
        beta_unknown_true * loc_unknown +
        beta_stage_III_true * stage_III +
        beta_stage_IV_true * stage_IV +
        beta_stage_unstaged_true * stage_unstaged
    ),
    y = rbinom(n(), size = 1, prob = p)
  )

cat("\n--- Simulated Outcome Diagnostics ---\n")

--- Simulated Outcome Diagnostics ---

cat("Number of rows:", nrow(d_sim_stage), "\n")

Number of rows: 189 

cat("Range of y:", paste(range(d_sim_stage$y), collapse = " to "), "\n")

Range of y: 0 to 1 

cat("Mean response rate:", round(mean(d_sim_stage$y), 3), "\n\n")

Mean response rate: 0.392 

cat("Outcome counts:\n")

Outcome counts:

print(table(d_sim_stage$y))

  0   1 
115  74 

cat("\nStage counts:\n")

Stage counts:

print(table(d_sim_stage$stage_condensed))

Stage I-II  Stage III   Stage IV   Unstaged 
         6         75         90         18 

16.5 Step 5: fit the model

alpha_mu <- qlogis(0.40)
beta_dose_mu <- 0
beta_age_mu <- 0
beta_imm_mu <- -0.8
beta_conj_mu <- -2.3
beta_other_mu <- 0
beta_unknown_mu <- 0
beta_stage_III_mu <- 0
beta_stage_IV_mu <- 0
beta_stage_unstaged_mu <- 0

dat_stage <- list(
  N = nrow(d_sim_stage),
  y = d_sim_stage$y,
  x = d_sim_stage$dose_minus_1,
  z = d_sim_stage$age_centered,
  w = d_sim_stage$immunosuppressed,
  loc_conj = d_sim_stage$loc_conj,
  loc_other = d_sim_stage$loc_other,
  loc_unknown = d_sim_stage$loc_unknown,
  stage_III = d_sim_stage$stage_III,
  stage_IV = d_sim_stage$stage_IV,
  stage_unstaged = d_sim_stage$stage_unstaged,
  alpha_mu = alpha_mu,
  beta_dose_mu = beta_dose_mu,
  beta_age_mu = beta_age_mu,
  beta_imm_mu = beta_imm_mu,
  beta_conj_mu = beta_conj_mu,
  beta_other_mu = beta_other_mu,
  beta_unknown_mu = beta_unknown_mu,
  beta_stage_III_mu = beta_stage_III_mu,
  beta_stage_IV_mu = beta_stage_IV_mu,
  beta_stage_unstaged_mu = beta_stage_unstaged_mu
)

# Note: generative logic runs conceptually bottom -> top:
#   1. Draw parameters from priors
#   2. Compute logit(p_i) from predictors and coefficients
#   3. Convert log-odds to probabilities
#   4. Generate y_i from Bernoulli(p_i)

m_stage <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_dose * x +
      beta_age * z +
      beta_imm * w +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged,
    
    alpha ~ normal(alpha_mu, 1.5),
    beta_dose ~ normal(beta_dose_mu, 0.5),
    beta_age ~ normal(beta_age_mu, 0.02),
    beta_imm ~ normal(beta_imm_mu, 0.2),
    beta_conj ~ normal(beta_conj_mu, 0.5),
    beta_other ~ normal(beta_other_mu, 0.3),
    beta_unknown ~ normal(beta_unknown_mu, 0.3),
    beta_stage_III ~ normal(beta_stage_III_mu, 0.3),
    beta_stage_IV ~ normal(beta_stage_IV_mu, 0.3),
    beta_stage_unstaged ~ normal(beta_stage_unstaged_mu, 0.3)
  ),
  data = dat_stage,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 0.6 seconds.
Chain 2 finished in 0.6 seconds.
Chain 3 finished in 0.6 seconds.
Chain 4 finished in 0.6 seconds.

All 4 chains finished successfully.
Mean chain execution time: 0.6 seconds.
Total execution time: 0.7 seconds.

16.6 Step 6: check whether it recovers the truth

precis(m_stage, depth = 2)

                           mean         sd        5.5%        94.5%      rhat
alpha               -0.09722446 0.27021777 -0.51817340  0.338059829 1.0015024
beta_dose           -0.07242062 0.04233025 -0.14530674 -0.008808823 1.0017788
beta_age            -0.01962164 0.01039606 -0.03640387 -0.003122669 0.9999385
beta_imm            -0.78159130 0.18973518 -1.08658919 -0.482757198 1.0010048
beta_conj           -1.95224768 0.43527628 -2.65586901 -1.271652994 1.0017698
beta_other           0.02452393 0.27148526 -0.41635033  0.454453225 1.0004010
beta_unknown         0.03295279 0.29558178 -0.44496844  0.515224018 1.0011004
beta_stage_III       0.19642785 0.23381411 -0.16697491  0.576116800 1.0007715
beta_stage_IV       -0.01699507 0.23665458 -0.40390281  0.359007053 0.9997813
beta_stage_unstaged -0.06627039 0.26899562 -0.48863564  0.361161821 1.0002523
                    ess_bulk
alpha               3418.371
beta_dose           4777.751
beta_age            5111.095
beta_imm            5139.127
beta_conj           5662.553
beta_other          5862.961
beta_unknown        5785.780
beta_stage_III      3814.762
beta_stage_IV       3956.527
beta_stage_unstaged 5262.082

trankplot(m_stage)

The true parameter values used to generate the data were:

• \(\alpha_{\text{true}} = \text{logit}(0.40) \approx -0.405\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)
• \(\beta_{\text{imm}}^{\text{true}} = -0.8\)
• \(\beta_{\text{conj}}^{\text{true}} = -2.3\)
• \(\beta_{\text{other}}^{\text{true}} = 0\)
• \(\beta_{\text{unknown}}^{\text{true}} = 0\)
• \(\beta_{\text{III}}^{\text{true}} = 0\)
• \(\beta_{\text{IV}}^{\text{true}} = 0\)
• \(\beta_{\text{unstaged}}^{\text{true}} = 0\)

The posterior summary should therefore recover values near those targets, with stage effects remaining near zero under this simulation scenario.

16.7 Step 7: prior predictive check for stage

For a multi-level categorical predictor, a grouped prior predictive plot is more informative than a fan plot. Here we compare the prior predictive response probability across stage groups while holding dose fixed at one dose, age fixed at 76 years, immunosuppression fixed at 0, and location fixed at Head/Neck.

set.seed(123)

n_prior <- 4000

prior_draws_stage <- tibble(
  alpha = rnorm(n_prior, mean = alpha_mu, sd = 1.5),
  beta_stage_III = rnorm(n_prior, mean = beta_stage_III_mu, sd = 0.3),
  beta_stage_IV = rnorm(n_prior, mean = beta_stage_IV_mu, sd = 0.3),
  beta_stage_unstaged = rnorm(n_prior, mean = beta_stage_unstaged_mu, sd = 0.3)
) |>
  mutate(
    p_stage_I_II = plogis(alpha),
    p_stage_III = plogis(alpha + beta_stage_III),
    p_stage_IV = plogis(alpha + beta_stage_IV),
    p_unstaged = plogis(alpha + beta_stage_unstaged)
  )

prior_stage_long <- bind_rows(
  prior_draws_stage |> transmute(group = "Stage I-II", p = p_stage_I_II),
  prior_draws_stage |> transmute(group = "Stage III", p = p_stage_III),
  prior_draws_stage |> transmute(group = "Stage IV", p = p_stage_IV),
  prior_draws_stage |> transmute(group = "Unstaged", p = p_unstaged)
) |>
  mutate(
    group = factor(group, levels = c("Stage I-II", "Stage III", "Stage IV", "Unstaged"))
  )

ggplot(prior_stage_long, aes(x = group, y = p, fill = group)) +
  geom_violin(alpha = 0.5, width = 0.9, color = NA) +
  stat_summary(fun = median, geom = "point", size = 2, color = "black") +
  stat_summary(
    fun.data = median_hilow,
    fun.args = list(conf.int = 0.8),
    geom = "errorbar",
    width = 0.15,
    linewidth = 0.8,
    color = "black"
  ) +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Prior Predictive Response by Stage",
    subtitle = "Dose fixed at one dose; age fixed at 76 years; not immunosuppressed; Head/Neck",
    x = NULL,
    y = "Response probability"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    legend.position = "none"
  )

This plot shows the prior predictive response distributions for each stage group before seeing any data. Under the skeptical prior, the stage effects are centered at zero, so the stage-specific distributions should largely overlap.

16.8 Step 8: prior vs posterior for the stage effects

post_stage <- extract.samples(m_stage)

plot_df_stage_III <- bind_rows(
  tibble(value = rnorm(4000, beta_stage_III_mu, 0.3), source = "Prior", term = "Stage III"),
  tibble(value = post_stage$beta_stage_III, source = "Posterior", term = "Stage III")
)

plot_df_stage_IV <- bind_rows(
  tibble(value = rnorm(4000, beta_stage_IV_mu, 0.3), source = "Prior", term = "Stage IV"),
  tibble(value = post_stage$beta_stage_IV, source = "Posterior", term = "Stage IV")
)

plot_df_stage_unstaged <- bind_rows(
  tibble(value = rnorm(4000, beta_stage_unstaged_mu, 0.3), source = "Prior", term = "Unstaged"),
  tibble(value = post_stage$beta_stage_unstaged, source = "Posterior", term = "Unstaged")
)

plot_df_stage <- bind_rows(
  plot_df_stage_III,
  plot_df_stage_IV,
  plot_df_stage_unstaged
)

ggplot(plot_df_stage, aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  facet_wrap(~ term, scales = "free") +
  geom_vline(xintercept = 0, linetype = "dashed") +
  labs(
    title = "Prior vs Posterior for Stage Effects",
    x = "Coefficient value",
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold")
  )

These panels compare the prior and posterior distributions for the three non-reference stage effects. Under the current simulation, the true stage effects are zero, so the posterior distributions should remain close to the prior and centered near zero.

16.9 Step 9: posterior predictive check

observed_rate_stage <- mean(d_sim_stage$y)

pp_rates_stage <- sapply(seq_along(post_stage$alpha), function(i) {
  p <- plogis(
    post_stage$alpha[i] +
      post_stage$beta_dose[i] * dat_stage$x +
      post_stage$beta_age[i] * dat_stage$z +
      post_stage$beta_imm[i] * dat_stage$w +
      post_stage$beta_conj[i] * dat_stage$loc_conj +
      post_stage$beta_other[i] * dat_stage$loc_other +
      post_stage$beta_unknown[i] * dat_stage$loc_unknown +
      post_stage$beta_stage_III[i] * dat_stage$stage_III +
      post_stage$beta_stage_IV[i] * dat_stage$stage_IV +
      post_stage$beta_stage_unstaged[i] * dat_stage$stage_unstaged
  )
  
  y_rep <- rbinom(dat_stage$N, size = 1, prob = p)
  mean(y_rep)
})

pp_df_stage <- tibble(
  simulated_response_rate = pp_rates_stage
)

ggplot(pp_df_stage, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(xintercept = observed_rate_stage, color = "red", linewidth = 1.2, linetype = "dashed") +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Stage Model",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

The histogram shows the distribution of response rates from datasets simulated under the posterior predictive distribution of the fitted model. If the observed response rate lies comfortably within this distribution, the model is capable of generating data similar to those observed.

---

17 Add a Sixth Predictor: Agent / Schedule

---

We now extend the model by adding treatment agent and schedule as a multi-level categorical predictor.

Rather than using a simplified agent variable, we distinguish schedule-specific pembrolizumab categories:

• Cemiplimab (reference)
• Pembro_q3
• Pembro_q6
• Pembro_mixed
• Ipi_Nivo

Using Cemiplimab as the reference category, the model estimates separate log-odds shifts for the other treatment groups.

This expanded treatment variable better reflects the treatment-delivery structure used in the dose-intensity analysis.

17.1 Step 1: specify the model mathematically

\[ \begin{aligned} y_i &\sim \text{Bernoulli}(p_i) \\ \text{logit}(p_i) &= \alpha + \beta_{\text{dose}} x_i + \beta_{\text{age}} z_i + \beta_{\text{imm}} w_i \\ &\quad + \beta_{\text{conj}} c_i + \beta_{\text{other}} o_i + \beta_{\text{unknown}} u_i \\ &\quad + \beta_{\text{III}} s_{III,i} + \beta_{\text{IV}} s_{IV,i} + \beta_{\text{unstaged}} s_{U,i} \\ &\quad + \beta_{\text{pembro q3}} a_{q3,i} + \beta_{\text{pembro q6}} a_{q6,i} + \beta_{\text{pembro mixed}} a_{mix,i} + \beta_{\text{ipi nivo}} a_{ipi,i} \\ \alpha &\sim \mathcal{N}(\text{logit}(0.40), 1.5) \\ \beta_{\text{dose}} &\sim \mathcal{N}(0, 0.5) \\ \beta_{\text{age}} &\sim \mathcal{N}(0, 0.02) \\ \beta_{\text{imm}} &\sim \mathcal{N}(-0.8, 0.2) \\ \beta_{\text{conj}} &\sim \mathcal{N}(-2.3, 0.5) \\ \beta_{\text{other}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{unknown}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{III}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{IV}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{unstaged}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{pembro q3}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{pembro q6}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{pembro mixed}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{ipi nivo}} &\sim \mathcal{N}(0.4, 0.3) \end{aligned} \]

where Cemiplimab is the reference treatment group.

17.2 Step 2: simulate the predictors

We now simulate dose, age, immunosuppression, location, stage, and agent/schedule before generating the outcome.

set.seed(123)

N <- 189

observed_doses <- c(
  rep(1, 11), rep(2, 79), rep(3, 19), rep(4, 18), rep(5, 11),
  rep(6, 9), rep(7, 6), rep(8, 9), rep(9, 5), rep(10, 1),
  rep(11, 3), rep(13, 2), rep(14, 3), rep(15, 2), rep(16, 3),
  rep(20, 1), rep(28, 1), rep(43, 1)
)

d_sim_agent <- tibble(
  patient_id = 1:N,
  num_doses = sample(observed_doses, N, replace = TRUE),
  age = rnorm(N, mean = 76, sd = 12),
  immunosuppressed = rbinom(N, size = 1, prob = 0.17),
  location_condensed = sample(
    c("Head/Neck", "Conjunctiva", "Other", "Unknown Primary"),
    N,
    replace = TRUE,
    prob = c(0.80, 0.08, 0.08, 0.04)
  ),
  agent_schedule = sample(
    c("Cemiplimab", "Pembro_q3", "Pembro_q6", "Pembro_mixed", "Ipi_Nivo"),
    N,
    replace = TRUE,
    prob = c(0.55, 0.18, 0.10, 0.07, 0.10)
  )
) |>
  mutate(
    dose_minus_1 = num_doses - 1,
    age_centered = age - 76,
    loc_conj = as.integer(location_condensed == "Conjunctiva"),
    loc_other = as.integer(location_condensed == "Other"),
    loc_unknown = as.integer(location_condensed == "Unknown Primary"),
    agent_pembro_q3 = as.integer(agent_schedule == "Pembro_q3"),
    agent_pembro_q6 = as.integer(agent_schedule == "Pembro_q6"),
    agent_pembro_mixed = as.integer(agent_schedule == "Pembro_mixed"),
    agent_ipi_nivo = as.integer(agent_schedule == "Ipi_Nivo")
  ) |>
  rowwise() |>
  mutate(
    stage_condensed = if_else(
      location_condensed == "Conjunctiva",
      sample(c("Stage III", "Stage IV", "Unstaged"), 1, prob = c(0.30, 0.50, 0.20)),
      sample(c("Stage I-II", "Stage III", "Stage IV", "Unstaged"), 1,
             prob = c(0.08, 0.38, 0.42, 0.12))
    )
  ) |>
  ungroup() |>
  mutate(
    stage_III = as.integer(stage_condensed == "Stage III"),
    stage_IV = as.integer(stage_condensed == "Stage IV"),
    stage_unstaged = as.integer(stage_condensed == "Unstaged")
  )

The generative order is therefore:

\[ x_i, z_i, w_i, c_i, o_i, u_i, s_i, a_i \rightarrow \alpha, \beta \rightarrow p_i \rightarrow y_i \]

More specifically:

1. Simulate dose count.
2. Compute \(x_i = \text{dose\_minus\_1}_i\).
3. Simulate age and compute \(z_i = \text{age\_centered}_i\).
4. Simulate immunosuppression status.
5. Simulate location and convert to indicator variables.
6. Simulate stage and convert to indicator variables.
7. Simulate treatment agent/schedule and convert to indicator variables.
8. Choose true parameter values.
9. Compute response probability \(p_i\) and simulate binary outcome \(y_i\).

17.3 Step 3: choose the true parameter values

For this simulation, we use:

• \(\alpha_{\text{true}} = \text{logit}(0.40)\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)
• \(\beta_{\text{imm}}^{\text{true}} = -0.8\)
• \(\beta_{\text{conj}}^{\text{true}} = -2.3\)
• \(\beta_{\text{other}}^{\text{true}} = 0\)
• \(\beta_{\text{unknown}}^{\text{true}} = 0\)
• \(\beta_{\text{III}}^{\text{true}} = 0\)
• \(\beta_{\text{IV}}^{\text{true}} = 0\)
• \(\beta_{\text{unstaged}}^{\text{true}} = 0\)
• \(\beta_{\text{pembro q3}}^{\text{true}} = 0\)
• \(\beta_{\text{pembro q6}}^{\text{true}} = 0\)
• \(\beta_{\text{pembro mixed}}^{\text{true}} = 0\)
• \(\beta_{\text{ipi nivo}}^{\text{true}} = 0.4\)

This means only Ipi+Nivo is given a modest positive treatment effect relative to Cemiplimab in the simulated data.

alpha_true <- qlogis(0.40)
beta_dose_true <- 0
beta_age_true <- -0.01
beta_imm_true <- -0.8
beta_conj_true <- -2.3
beta_other_true <- 0
beta_unknown_true <- 0
beta_stage_III_true <- 0
beta_stage_IV_true <- 0
beta_stage_unstaged_true <- 0
beta_pembro_q3_true <- 0
beta_pembro_q6_true <- 0
beta_pembro_mixed_true <- 0
beta_ipi_nivo_true <- 0.4

17.4 Step 4: simulate the outcome

d_sim_agent <- d_sim_agent |>
  mutate(
    p = plogis(
      alpha_true +
        beta_dose_true * dose_minus_1 +
        beta_age_true * age_centered +
        beta_imm_true * immunosuppressed +
        beta_conj_true * loc_conj +
        beta_other_true * loc_other +
        beta_unknown_true * loc_unknown +
        beta_stage_III_true * stage_III +
        beta_stage_IV_true * stage_IV +
        beta_stage_unstaged_true * stage_unstaged +
        beta_pembro_q3_true * agent_pembro_q3 +
        beta_pembro_q6_true * agent_pembro_q6 +
        beta_pembro_mixed_true * agent_pembro_mixed +
        beta_ipi_nivo_true * agent_ipi_nivo
    ),
    y = rbinom(n(), size = 1, prob = p)
  )

cat("\n--- Simulated Outcome Diagnostics ---\n")

--- Simulated Outcome Diagnostics ---

cat("Number of rows:", nrow(d_sim_agent), "\n")

Number of rows: 189 

cat("Range of y:", paste(range(d_sim_agent$y), collapse = " to "), "\n")

Range of y: 0 to 1 

cat("Mean response rate:", round(mean(d_sim_agent$y), 3), "\n\n")

Mean response rate: 0.413 

cat("Outcome counts:\n")

Outcome counts:

print(table(d_sim_agent$y))

  0   1 
111  78 

cat("\nAgent/schedule counts:\n")

Agent/schedule counts:

print(table(d_sim_agent$agent_schedule))

  Cemiplimab     Ipi_Nivo Pembro_mixed    Pembro_q3    Pembro_q6 
         104           15           11           39           20 

17.5 Step 5: fit the model

alpha_mu <- qlogis(0.40)
beta_dose_mu <- 0
beta_age_mu <- 0
beta_imm_mu <- -0.8
beta_conj_mu <- -2.3
beta_other_mu <- 0
beta_unknown_mu <- 0
beta_stage_III_mu <- 0
beta_stage_IV_mu <- 0
beta_stage_unstaged_mu <- 0
beta_pembro_q3_mu <- 0
beta_pembro_q6_mu <- 0
beta_pembro_mixed_mu <- 0
beta_ipi_nivo_mu <- 0.4

dat_agent <- list(
  N = nrow(d_sim_agent),
  y = d_sim_agent$y,
  x = d_sim_agent$dose_minus_1,
  z = d_sim_agent$age_centered,
  w = d_sim_agent$immunosuppressed,
  loc_conj = d_sim_agent$loc_conj,
  loc_other = d_sim_agent$loc_other,
  loc_unknown = d_sim_agent$loc_unknown,
  stage_III = d_sim_agent$stage_III,
  stage_IV = d_sim_agent$stage_IV,
  stage_unstaged = d_sim_agent$stage_unstaged,
  agent_pembro_q3 = d_sim_agent$agent_pembro_q3,
  agent_pembro_q6 = d_sim_agent$agent_pembro_q6,
  agent_pembro_mixed = d_sim_agent$agent_pembro_mixed,
  agent_ipi_nivo = d_sim_agent$agent_ipi_nivo,
  alpha_mu = alpha_mu,
  beta_dose_mu = beta_dose_mu,
  beta_age_mu = beta_age_mu,
  beta_imm_mu = beta_imm_mu,
  beta_conj_mu = beta_conj_mu,
  beta_other_mu = beta_other_mu,
  beta_unknown_mu = beta_unknown_mu,
  beta_stage_III_mu = beta_stage_III_mu,
  beta_stage_IV_mu = beta_stage_IV_mu,
  beta_stage_unstaged_mu = beta_stage_unstaged_mu,
  beta_pembro_q3_mu = beta_pembro_q3_mu,
  beta_pembro_q6_mu = beta_pembro_q6_mu,
  beta_pembro_mixed_mu = beta_pembro_mixed_mu,
  beta_ipi_nivo_mu = beta_ipi_nivo_mu
)

m_agent <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_dose * x +
      beta_age * z +
      beta_imm * w +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged +
      beta_pembro_q3 * agent_pembro_q3 +
      beta_pembro_q6 * agent_pembro_q6 +
      beta_pembro_mixed * agent_pembro_mixed +
      beta_ipi_nivo * agent_ipi_nivo,
    
    alpha ~ normal(alpha_mu, 1.5),
    beta_dose ~ normal(beta_dose_mu, 0.5),
    beta_age ~ normal(beta_age_mu, 0.02),
    beta_imm ~ normal(beta_imm_mu, 0.2),
    beta_conj ~ normal(beta_conj_mu, 0.5),
    beta_other ~ normal(beta_other_mu, 0.3),
    beta_unknown ~ normal(beta_unknown_mu, 0.3),
    beta_stage_III ~ normal(beta_stage_III_mu, 0.3),
    beta_stage_IV ~ normal(beta_stage_IV_mu, 0.3),
    beta_stage_unstaged ~ normal(beta_stage_unstaged_mu, 0.3),
    beta_pembro_q3 ~ normal(beta_pembro_q3_mu, 0.3),
    beta_pembro_q6 ~ normal(beta_pembro_q6_mu, 0.3),
    beta_pembro_mixed ~ normal(beta_pembro_mixed_mu, 0.3),
    beta_ipi_nivo ~ normal(beta_ipi_nivo_mu, 0.3)
  ),
  data = dat_agent,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 finished in 0.9 seconds.
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 finished in 0.9 seconds.
Chain 4 finished in 1.0 seconds.
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 1.1 seconds.

All 4 chains finished successfully.
Mean chain execution time: 1.0 seconds.
Total execution time: 1.2 seconds.

17.6 Step 6: check whether it recovers the truth

precis(m_agent, depth = 2)

                            mean         sd        5.5%        94.5%      rhat
alpha               -0.056849045 0.25786535 -0.47688893  0.357317697 1.0020334
beta_dose           -0.028124993 0.03676048 -0.08802715  0.029023175 1.0001836
beta_age            -0.009034596 0.01046630 -0.02593588  0.007993734 0.9999435
beta_imm            -0.760160298 0.18191663 -1.05022620 -0.475633398 1.0015330
beta_conj           -2.184770184 0.44115316 -2.88632277 -1.484227504 1.0006737
beta_other           0.102915105 0.26839096 -0.33327115  0.532476070 0.9996264
beta_unknown         0.017532208 0.28788653 -0.44114805  0.470657896 1.0001015
beta_stage_III      -0.048943403 0.23095125 -0.42135906  0.311208864 1.0007499
beta_stage_IV       -0.055649602 0.23178029 -0.42276750  0.306993999 1.0033379
beta_stage_unstaged  0.020278953 0.26195134 -0.40161885  0.441210634 1.0016368
beta_pembro_q3       0.098448161 0.23894433 -0.28590510  0.483668810 0.9998920
beta_pembro_q6      -0.170384580 0.25723203 -0.58569945  0.235817069 1.0001145
beta_pembro_mixed    0.033724914 0.27490536 -0.41822472  0.471015981 0.9999831
beta_ipi_nivo        0.314384448 0.26881703 -0.12372339  0.737232501 1.0011316
                    ess_bulk
alpha               3929.912
beta_dose           5369.641
beta_age            6648.004
beta_imm            6701.995
beta_conj           6210.469
beta_other          6864.221
beta_unknown        6590.523
beta_stage_III      4778.888
beta_stage_IV       4487.284
beta_stage_unstaged 6355.828
beta_pembro_q3      6134.609
beta_pembro_q6      6880.496
beta_pembro_mixed   6324.918
beta_ipi_nivo       5945.089

The true parameter values used to generate the data were the same as in prior sections, with the addition of the treatment effects:

• \(\beta_{\text{pembro q3}}^{\text{true}} = 0\)
• \(\beta_{\text{pembro q6}}^{\text{true}} = 0\)
• \(\beta_{\text{pembro mixed}}^{\text{true}} = 0\)
• \(\beta_{\text{ipi nivo}}^{\text{true}} = 0.4\)

The posterior summary should therefore recover values near those targets, with the Ipi+Nivo coefficient shifted modestly positive relative to the reference group.

17.7 Step 7: prior predictive check for agent / schedule

For a multi-level categorical predictor, a grouped prior predictive plot is more informative than a fan plot. Here we compare the prior predictive response probability across treatment groups while holding dose fixed at one dose, age fixed at 76 years, immunosuppression fixed at 0, location fixed at Head/Neck, and stage fixed at Stage I-II.

set.seed(123)

n_prior <- 4000

prior_draws_agent <- tibble(
  alpha = rnorm(n_prior, mean = alpha_mu, sd = 1.5),
  beta_pembro_q3 = rnorm(n_prior, mean = beta_pembro_q3_mu, sd = 0.3),
  beta_pembro_q6 = rnorm(n_prior, mean = beta_pembro_q6_mu, sd = 0.3),
  beta_pembro_mixed = rnorm(n_prior, mean = beta_pembro_mixed_mu, sd = 0.3),
  beta_ipi_nivo = rnorm(n_prior, mean = beta_ipi_nivo_mu, sd = 0.3)
) |>
  mutate(
    p_cemiplimab = plogis(alpha),
    p_pembro_q3 = plogis(alpha + beta_pembro_q3),
    p_pembro_q6 = plogis(alpha + beta_pembro_q6),
    p_pembro_mixed = plogis(alpha + beta_pembro_mixed),
    p_ipi_nivo = plogis(alpha + beta_ipi_nivo)
  )

prior_agent_long <- bind_rows(
  prior_draws_agent |> transmute(group = "Cemiplimab", p = p_cemiplimab),
  prior_draws_agent |> transmute(group = "Pembro_q3", p = p_pembro_q3),
  prior_draws_agent |> transmute(group = "Pembro_q6", p = p_pembro_q6),
  prior_draws_agent |> transmute(group = "Pembro_mixed", p = p_pembro_mixed),
  prior_draws_agent |> transmute(group = "Ipi_Nivo", p = p_ipi_nivo)
) |>
  mutate(
    group = factor(group, levels = c("Cemiplimab", "Pembro_q3", "Pembro_q6", "Pembro_mixed", "Ipi_Nivo"))
  )

ggplot(prior_agent_long, aes(x = group, y = p, fill = group)) +
  geom_violin(alpha = 0.5, width = 0.9, color = NA) +
  stat_summary(fun = median, geom = "point", size = 2, color = "black") +
  stat_summary(
    fun.data = median_hilow,
    fun.args = list(conf.int = 0.8),
    geom = "errorbar",
    width = 0.15,
    linewidth = 0.8,
    color = "black"
  ) +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Prior Predictive Response by Agent / Schedule",
    subtitle = "Dose fixed at one dose; age fixed at 76 years; not immunosuppressed; Head/Neck; Stage I-II",
    x = NULL,
    y = "Response probability"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    legend.position = "none"
  )

17.8 Step 8: prior vs posterior for the agent / schedule effects

post_agent <- extract.samples(m_agent)

plot_df_q3 <- bind_rows(
  tibble(value = rnorm(4000, beta_pembro_q3_mu, 0.3), source = "Prior", term = "Pembro_q3"),
  tibble(value = post_agent$beta_pembro_q3, source = "Posterior", term = "Pembro_q3")
)

plot_df_q6 <- bind_rows(
  tibble(value = rnorm(4000, beta_pembro_q6_mu, 0.3), source = "Prior", term = "Pembro_q6"),
  tibble(value = post_agent$beta_pembro_q6, source = "Posterior", term = "Pembro_q6")
)

plot_df_mix <- bind_rows(
  tibble(value = rnorm(4000, beta_pembro_mixed_mu, 0.3), source = "Prior", term = "Pembro_mixed"),
  tibble(value = post_agent$beta_pembro_mixed, source = "Posterior", term = "Pembro_mixed")
)

plot_df_ipi <- bind_rows(
  tibble(value = rnorm(4000, beta_ipi_nivo_mu, 0.3), source = "Prior", term = "Ipi_Nivo"),
  tibble(value = post_agent$beta_ipi_nivo, source = "Posterior", term = "Ipi_Nivo")
)

plot_df_agent <- bind_rows(plot_df_q3, plot_df_q6, plot_df_mix, plot_df_ipi)

ggplot(plot_df_agent, aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  facet_wrap(~ term, scales = "free") +
  geom_vline(xintercept = 0, linetype = "dashed") +
  labs(
    title = "Prior vs Posterior for Agent / Schedule Effects",
    x = "Coefficient value",
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold")
  )

17.9 Step 9: posterior predictive check

observed_rate_agent <- mean(d_sim_agent$y)

pp_rates_agent <- sapply(seq_along(post_agent$alpha), function(i) {
  p <- plogis(
    post_agent$alpha[i] +
      post_agent$beta_dose[i] * dat_agent$x +
      post_agent$beta_age[i] * dat_agent$z +
      post_agent$beta_imm[i] * dat_agent$w +
      post_agent$beta_conj[i] * dat_agent$loc_conj +
      post_agent$beta_other[i] * dat_agent$loc_other +
      post_agent$beta_unknown[i] * dat_agent$loc_unknown +
      post_agent$beta_stage_III[i] * dat_agent$stage_III +
      post_agent$beta_stage_IV[i] * dat_agent$stage_IV +
      post_agent$beta_stage_unstaged[i] * dat_agent$stage_unstaged +
      post_agent$beta_pembro_q3[i] * dat_agent$agent_pembro_q3 +
      post_agent$beta_pembro_q6[i] * dat_agent$agent_pembro_q6 +
      post_agent$beta_pembro_mixed[i] * dat_agent$agent_pembro_mixed +
      post_agent$beta_ipi_nivo[i] * dat_agent$agent_ipi_nivo
  )
  
  y_rep <- rbinom(dat_agent$N, size = 1, prob = p)
  mean(y_rep)
})

pp_df_agent <- tibble(
  simulated_response_rate = pp_rates_agent
)

ggplot(pp_df_agent, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(xintercept = observed_rate_agent, color = "red", linewidth = 1.2, linetype = "dashed") +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Agent / Schedule Model",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

---

18 Add a Seventh Predictor: ECOG (Condensed)

---

We now extend the model by adding a binary predictor for ECOG performance status.

The condensed ECOG variable has two levels:

• ECOG 0-1 (reference)
• ECOG 2-3

Using ECOG 0-1 as the reference category, the model estimates a single coefficient representing the change in log-odds of response for patients with worse performance status.

Because this is a binary variable, the coefficient is interpreted as a between-group shift rather than a per-unit slope.

18.1 Step 1: specify the model mathematically

\[ \begin{aligned} y_i &\sim \text{Bernoulli}(p_i) \\ \text{logit}(p_i) &= \alpha + \beta_{\text{dose}} x_i + \beta_{\text{age}} z_i + \beta_{\text{imm}} w_i \\ &\quad + \beta_{\text{conj}} c_i + \beta_{\text{other}} o_i + \beta_{\text{unknown}} u_i \\ &\quad + \beta_{\text{III}} s_{III,i} + \beta_{\text{IV}} s_{IV,i} + \beta_{\text{unstaged}} s_{U,i} \\ &\quad + \beta_{\text{pembro q3}} a_{q3,i} + \beta_{\text{pembro q6}} a_{q6,i} + \beta_{\text{pembro mixed}} a_{mix,i} + \beta_{\text{ipi nivo}} a_{ipi,i} \\ &\quad + \beta_{\text{ECOG}} e_i \\ \alpha &\sim \mathcal{N}(\text{logit}(0.40), 1.5) \\ \beta_{\text{dose}} &\sim \mathcal{N}(0, 0.5) \\ \beta_{\text{age}} &\sim \mathcal{N}(0, 0.02) \\ \beta_{\text{imm}} &\sim \mathcal{N}(-0.8, 0.2) \\ \beta_{\text{conj}} &\sim \mathcal{N}(-2.3, 0.5) \\ \beta_{\text{other}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{unknown}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{III}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{IV}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{unstaged}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{pembro q3}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{pembro q6}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{pembro mixed}} &\sim \mathcal{N}(0, 0.3) \\ \beta_{\text{ipi nivo}} &\sim \mathcal{N}(0.4, 0.3) \\ \beta_{\text{ECOG}} &\sim \mathcal{N}(-0.3, 0.3) \end{aligned} \]

where:

• \(x_i = \text{dose\_minus\_1}_i\)
• \(z_i = \text{age\_centered}_i\)
• \(w_i = \text{immunosuppressed}_i\)
• \(c_i = 1\) if location is Conjunctiva, else 0
• \(o_i = 1\) if location is Other, else 0
• \(u_i = 1\) if location is Unknown Primary, else 0
• \(s_{III,i} = 1\) if stage is Stage III, else 0
• \(s_{IV,i} = 1\) if stage is Stage IV, else 0
• \(s_{U,i} = 1\) if stage is Unstaged, else 0
• \(a_{q3,i} = 1\) if agent is Pembro_q3, else 0
• \(a_{q6,i} = 1\) if agent is Pembro_q6, else 0
• \(a_{mix,i} = 1\) if agent is Pembro_mixed, else 0
• \(a_{ipi,i} = 1\) if agent is Ipi_Nivo, else 0
• \(e_i = 1\) if ECOG is 2-3, else 0

18.2 Step 2: simulate the predictors

We now simulate dose, age, immunosuppression, location, stage, agent/schedule, and ECOG before generating the outcome.

set.seed(123)

N <- 189

observed_doses <- c(
  rep(1, 11), rep(2, 79), rep(3, 19), rep(4, 18), rep(5, 11),
  rep(6, 9), rep(7, 6), rep(8, 9), rep(9, 5), rep(10, 1),
  rep(11, 3), rep(13, 2), rep(14, 3), rep(15, 2), rep(16, 3),
  rep(20, 1), rep(28, 1), rep(43, 1)
)

d_sim_ecog <- tibble(
  patient_id = 1:N,
  num_doses = sample(observed_doses, N, replace = TRUE),
  age = rnorm(N, mean = 76, sd = 12),
  immunosuppressed = rbinom(N, size = 1, prob = 0.17),
  location_condensed = sample(
    c("Head/Neck", "Conjunctiva", "Other", "Unknown Primary"),
    N,
    replace = TRUE,
    prob = c(0.80, 0.08, 0.08, 0.04)
  ),
  agent_schedule = sample(
    c("Cemiplimab", "Pembro_q3", "Pembro_q6", "Pembro_mixed", "Ipi_Nivo"),
    N,
    replace = TRUE,
    prob = c(0.55, 0.18, 0.10, 0.07, 0.10)
  )
) |>
  mutate(
    dose_minus_1 = num_doses - 1,
    age_centered = age - 76,
    loc_conj = as.integer(location_condensed == "Conjunctiva"),
    loc_other = as.integer(location_condensed == "Other"),
    loc_unknown = as.integer(location_condensed == "Unknown Primary"),
    agent_pembro_q3 = as.integer(agent_schedule == "Pembro_q3"),
    agent_pembro_q6 = as.integer(agent_schedule == "Pembro_q6"),
    agent_pembro_mixed = as.integer(agent_schedule == "Pembro_mixed"),
    agent_ipi_nivo = as.integer(agent_schedule == "Ipi_Nivo")
  ) |>
  rowwise() |>
  mutate(
    stage_condensed = if_else(
      location_condensed == "Conjunctiva",
      sample(c("Stage III", "Stage IV", "Unstaged"), 1, prob = c(0.30, 0.50, 0.20)),
      sample(c("Stage I-II", "Stage III", "Stage IV", "Unstaged"), 1,
             prob = c(0.08, 0.38, 0.42, 0.12))
    )
  ) |>
  ungroup() |>
  mutate(
    stage_III = as.integer(stage_condensed == "Stage III"),
    stage_IV = as.integer(stage_condensed == "Stage IV"),
    stage_unstaged = as.integer(stage_condensed == "Unstaged")
  )

# Simulate ECOG from a latent performance-status score influenced by age,
# immunosuppression, and stage
d_sim_ecog <- d_sim_ecog |>
  mutate(
    ps_score =
      scale(age)[,1] * 0.3 +
      ifelse(immunosuppressed == 1, 0.5, 0) +
      case_when(
        stage_condensed == "Stage I-II" ~ -0.4,
        stage_condensed == "Stage III" ~ 0,
        stage_condensed == "Stage IV" ~ 0.5,
        stage_condensed == "Unstaged" ~ 0.1
      ) +
      rnorm(N, 0, 0.8),
    
    ecog = case_when(
      ps_score < -0.5 ~ 0,
      ps_score <  0.5 ~ 1,
      ps_score <  1.5 ~ 2,
      TRUE ~ 3
    ),
    
    ecog_condensed = if_else(ecog <= 1, "ECOG 0-1", "ECOG 2-3"),
    ecog_23 = as.integer(ecog_condensed == "ECOG 2-3")
  )

The generative order is therefore:

\[ x_i, z_i, w_i, c_i, o_i, u_i, s_i, a_i, e_i \rightarrow \alpha, \beta \rightarrow p_i \rightarrow y_i \]

More specifically:

1. Simulate dose count.
2. Compute \(x_i = \text{dose\_minus\_1}_i\).
3. Simulate age and compute \(z_i = \text{age\_centered}_i\).
4. Simulate immunosuppression status.
5. Simulate location and convert to indicator variables.
6. Simulate stage and convert to indicator variables.
7. Simulate agent/schedule and convert to indicator variables.
8. Simulate ECOG from a latent performance-status score and condense to ECOG 0-1 vs ECOG 2-3.
9. Choose true parameter values, compute \(p_i\), and simulate \(y_i\).

18.3 Step 3: choose the true parameter values

For this simulation, we use:

• \(\alpha_{\text{true}} = \text{logit}(0.40)\)
• \(\beta_{\text{dose}}^{\text{true}} = 0\)
• \(\beta_{\text{age}}^{\text{true}} = -0.01\)
• \(\beta_{\text{imm}}^{\text{true}} = -0.8\)
• \(\beta_{\text{conj}}^{\text{true}} = -2.3\)
• \(\beta_{\text{other}}^{\text{true}} = 0\)
• \(\beta_{\text{unknown}}^{\text{true}} = 0\)
• \(\beta_{\text{III}}^{\text{true}} = 0\)
• \(\beta_{\text{IV}}^{\text{true}} = 0\)
• \(\beta_{\text{unstaged}}^{\text{true}} = 0\)
• \(\beta_{\text{pembro q3}}^{\text{true}} = 0\)
• \(\beta_{\text{pembro q6}}^{\text{true}} = 0\)
• \(\beta_{\text{pembro mixed}}^{\text{true}} = 0\)
• \(\beta_{\text{ipi nivo}}^{\text{true}} = 0.4\)
• \(\beta_{\text{ECOG}}^{\text{true}} = -0.3\)

This means worse performance status lowers the log-odds of response relative to ECOG 0-1.

alpha_true <- qlogis(0.40)
beta_dose_true <- 0
beta_age_true <- -0.01
beta_imm_true <- -0.8
beta_conj_true <- -2.3
beta_other_true <- 0
beta_unknown_true <- 0
beta_stage_III_true <- 0
beta_stage_IV_true <- 0
beta_stage_unstaged_true <- 0
beta_pembro_q3_true <- 0
beta_pembro_q6_true <- 0
beta_pembro_mixed_true <- 0
beta_ipi_nivo_true <- 0.4
beta_ecog_true <- -0.3

18.4 Step 4: simulate the outcome

d_sim_ecog <- d_sim_ecog |>
  mutate(
    p = plogis(
      alpha_true +
        beta_dose_true * dose_minus_1 +
        beta_age_true * age_centered +
        beta_imm_true * immunosuppressed +
        beta_conj_true * loc_conj +
        beta_other_true * loc_other +
        beta_unknown_true * loc_unknown +
        beta_stage_III_true * stage_III +
        beta_stage_IV_true * stage_IV +
        beta_stage_unstaged_true * stage_unstaged +
        beta_pembro_q3_true * agent_pembro_q3 +
        beta_pembro_q6_true * agent_pembro_q6 +
        beta_pembro_mixed_true * agent_pembro_mixed +
        beta_ipi_nivo_true * agent_ipi_nivo +
        beta_ecog_true * ecog_23
    ),
    y = rbinom(n(), size = 1, prob = p)
  )

cat("\n--- Simulated Outcome Diagnostics ---\n")

--- Simulated Outcome Diagnostics ---

cat("Number of rows:", nrow(d_sim_ecog), "\n")

Number of rows: 189 

cat("Range of y:", paste(range(d_sim_ecog$y), collapse = " to "), "\n")

Range of y: 0 to 1 

cat("Mean response rate:", round(mean(d_sim_ecog$y), 3), "\n\n")

Mean response rate: 0.312 

cat("Outcome counts:\n")

Outcome counts:

print(table(d_sim_ecog$y))

  0   1 
130  59 

cat("\nECOG counts:\n")

ECOG counts:

print(table(d_sim_ecog$ecog_condensed))

ECOG 0-1 ECOG 2-3 
     109       80 

18.5 Step 5: fit the model

alpha_mu <- qlogis(0.40)
beta_dose_mu <- 0
beta_age_mu <- 0
beta_imm_mu <- -0.8
beta_conj_mu <- -2.3
beta_other_mu <- 0
beta_unknown_mu <- 0
beta_stage_III_mu <- 0
beta_stage_IV_mu <- 0
beta_stage_unstaged_mu <- 0
beta_pembro_q3_mu <- 0
beta_pembro_q6_mu <- 0
beta_pembro_mixed_mu <- 0
beta_ipi_nivo_mu <- 0.4
beta_ecog_mu <- -0.3

dat_ecog <- list(
  N = nrow(d_sim_ecog),
  y = d_sim_ecog$y,
  x = d_sim_ecog$dose_minus_1,
  z = d_sim_ecog$age_centered,
  w = d_sim_ecog$immunosuppressed,
  loc_conj = d_sim_ecog$loc_conj,
  loc_other = d_sim_ecog$loc_other,
  loc_unknown = d_sim_ecog$loc_unknown,
  stage_III = d_sim_ecog$stage_III,
  stage_IV = d_sim_ecog$stage_IV,
  stage_unstaged = d_sim_ecog$stage_unstaged,
  agent_pembro_q3 = d_sim_ecog$agent_pembro_q3,
  agent_pembro_q6 = d_sim_ecog$agent_pembro_q6,
  agent_pembro_mixed = d_sim_ecog$agent_pembro_mixed,
  agent_ipi_nivo = d_sim_ecog$agent_ipi_nivo,
  ecog_23 = d_sim_ecog$ecog_23,
  alpha_mu = alpha_mu,
  beta_dose_mu = beta_dose_mu,
  beta_age_mu = beta_age_mu,
  beta_imm_mu = beta_imm_mu,
  beta_conj_mu = beta_conj_mu,
  beta_other_mu = beta_other_mu,
  beta_unknown_mu = beta_unknown_mu,
  beta_stage_III_mu = beta_stage_III_mu,
  beta_stage_IV_mu = beta_stage_IV_mu,
  beta_stage_unstaged_mu = beta_stage_unstaged_mu,
  beta_pembro_q3_mu = beta_pembro_q3_mu,
  beta_pembro_q6_mu = beta_pembro_q6_mu,
  beta_pembro_mixed_mu = beta_pembro_mixed_mu,
  beta_ipi_nivo_mu = beta_ipi_nivo_mu,
  beta_ecog_mu = beta_ecog_mu
)

m_ecog <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_dose * x +
      beta_age * z +
      beta_imm * w +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged +
      beta_pembro_q3 * agent_pembro_q3 +
      beta_pembro_q6 * agent_pembro_q6 +
      beta_pembro_mixed * agent_pembro_mixed +
      beta_ipi_nivo * agent_ipi_nivo +
      beta_ecog * ecog_23,
    
    alpha ~ normal(alpha_mu, 1.5),
    beta_dose ~ normal(beta_dose_mu, 0.5),
    beta_age ~ normal(beta_age_mu, 0.02),
    beta_imm ~ normal(beta_imm_mu, 0.2),
    beta_conj ~ normal(beta_conj_mu, 0.5),
    beta_other ~ normal(beta_other_mu, 0.3),
    beta_unknown ~ normal(beta_unknown_mu, 0.3),
    beta_stage_III ~ normal(beta_stage_III_mu, 0.3),
    beta_stage_IV ~ normal(beta_stage_IV_mu, 0.3),
    beta_stage_unstaged ~ normal(beta_stage_unstaged_mu, 0.3),
    beta_pembro_q3 ~ normal(beta_pembro_q3_mu, 0.3),
    beta_pembro_q6 ~ normal(beta_pembro_q6_mu, 0.3),
    beta_pembro_mixed ~ normal(beta_pembro_mixed_mu, 0.3),
    beta_ipi_nivo ~ normal(beta_ipi_nivo_mu, 0.3),
    beta_ecog ~ normal(beta_ecog_mu, 0.3)
  ),
  data = dat_ecog,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 1.0 seconds.
Chain 2 finished in 1.0 seconds.
Chain 3 finished in 1.0 seconds.
Chain 4 finished in 1.0 seconds.

All 4 chains finished successfully.
Mean chain execution time: 1.0 seconds.
Total execution time: 1.1 seconds.

18.6 Step 6: check whether it recovers the truth

precis(m_ecog, depth = 2)

                            mean         sd        5.5%        94.5%      rhat
alpha               -0.699701472 0.26967730 -1.13200519 -0.271715874 1.0009080
beta_dose            0.032481220 0.03495168 -0.02201663  0.088581918 1.0023393
beta_age            -0.006802374 0.01075987 -0.02365796  0.009770931 1.0018307
beta_imm            -0.866557365 0.18913583 -1.17160194 -0.565161201 1.0019578
beta_conj           -2.493900417 0.45630533 -3.23252393 -1.750682368 1.0022701
beta_other           0.191832989 0.27333660 -0.25449510  0.629309510 1.0010096
beta_unknown        -0.020113562 0.29507059 -0.48604660  0.444235005 1.0018408
beta_stage_III      -0.223078681 0.23673694 -0.59788922  0.158620836 1.0010269
beta_stage_IV        0.187873228 0.23439902 -0.19462947  0.562171835 1.0003481
beta_stage_unstaged  0.169420394 0.26002862 -0.25315681  0.589550146 1.0030376
beta_pembro_q3       0.059552092 0.24022575 -0.33239485  0.450621696 1.0016331
beta_pembro_q6       0.031176472 0.25731486 -0.38375614  0.445585240 0.9996368
beta_pembro_mixed   -0.036307063 0.27503299 -0.47105996  0.403192295 1.0003048
beta_ipi_nivo        0.244328475 0.27061595 -0.18808724  0.673057867 1.0037692
beta_ecog           -0.227782545 0.22319443 -0.57833424  0.131093383 1.0009334
                    ess_bulk
alpha               4063.726
beta_dose           5650.127
beta_age            7014.872
beta_imm            6332.919
beta_conj           6996.340
beta_other          8108.631
beta_unknown        6111.455
beta_stage_III      5608.448
beta_stage_IV       4727.552
beta_stage_unstaged 6137.417
beta_pembro_q3      6041.710
beta_pembro_q6      7140.630
beta_pembro_mixed   6091.841
beta_ipi_nivo       9042.143
beta_ecog           6705.414

The true parameter values used to generate the data were the same as in prior sections, with the addition of:

• \(\beta_{\text{ECOG}}^{\text{true}} = -0.3\)

The posterior summary should therefore recover a modest negative ECOG effect, indicating lower response probability for patients with ECOG 2-3 relative to ECOG 0-1.

18.7 Step 7: prior predictive check for ECOG

For a binary variable like ECOG, a grouped prior predictive plot is more informative than a fan plot. Here we compare the prior predictive response probability for ECOG 0-1 and ECOG 2-3 while holding dose fixed at one dose, age fixed at 76 years, immunosuppression fixed at 0, location fixed at Head/Neck, stage fixed at Stage I-II, and agent fixed at Cemiplimab.

set.seed(123)

n_prior <- 4000

prior_draws_ecog <- tibble(
  alpha = rnorm(n_prior, mean = alpha_mu, sd = 1.5),
  beta_ecog = rnorm(n_prior, mean = beta_ecog_mu, sd = 0.3)
) |>
  mutate(
    p_ecog_01 = plogis(alpha),
    p_ecog_23 = plogis(alpha + beta_ecog)
  )

prior_ecog_long <- bind_rows(
  prior_draws_ecog |> transmute(group = "ECOG 0-1", p = p_ecog_01),
  prior_draws_ecog |> transmute(group = "ECOG 2-3", p = p_ecog_23)
) |>
  mutate(
    group = factor(group, levels = c("ECOG 0-1", "ECOG 2-3"))
  )

ggplot(prior_ecog_long, aes(x = group, y = p, fill = group)) +
  geom_violin(alpha = 0.5, width = 0.9, color = NA) +
  stat_summary(fun = median, geom = "point", size = 2, color = "black") +
  stat_summary(
    fun.data = median_hilow,
    fun.args = list(conf.int = 0.8),
    geom = "errorbar",
    width = 0.15,
    linewidth = 0.8,
    color = "black"
  ) +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Prior Predictive Response by ECOG",
    subtitle = "Dose fixed at one dose; age fixed at 76 years; not immunosuppressed; Head/Neck; Stage I-II; Cemiplimab",
    x = NULL,
    y = "Response probability"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    legend.position = "none"
  )

18.8 Step 8: prior vs posterior for the ECOG effect

post_ecog <- extract.samples(m_ecog)

plot_df_ecog <- bind_rows(
  tibble(value = rnorm(4000, beta_ecog_mu, 0.3), source = "Prior"),
  tibble(value = post_ecog$beta_ecog, source = "Posterior")
)

ggplot(plot_df_ecog, aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  geom_vline(xintercept = 0, linetype = "dashed") +
  labs(
    title = "Prior vs Posterior for ECOG Effect",
    x = expression(beta[ECOG]),
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold")
  )

18.9 Step 9: posterior predictive check

observed_rate_ecog <- mean(d_sim_ecog$y)

pp_rates_ecog <- sapply(seq_along(post_ecog$alpha), function(i) {
  p <- plogis(
    post_ecog$alpha[i] +
      post_ecog$beta_dose[i] * dat_ecog$x +
      post_ecog$beta_age[i] * dat_ecog$z +
      post_ecog$beta_imm[i] * dat_ecog$w +
      post_ecog$beta_conj[i] * dat_ecog$loc_conj +
      post_ecog$beta_other[i] * dat_ecog$loc_other +
      post_ecog$beta_unknown[i] * dat_ecog$loc_unknown +
      post_ecog$beta_stage_III[i] * dat_ecog$stage_III +
      post_ecog$beta_stage_IV[i] * dat_ecog$stage_IV +
      post_ecog$beta_stage_unstaged[i] * dat_ecog$stage_unstaged +
      post_ecog$beta_pembro_q3[i] * dat_ecog$agent_pembro_q3 +
      post_ecog$beta_pembro_q6[i] * dat_ecog$agent_pembro_q6 +
      post_ecog$beta_pembro_mixed[i] * dat_ecog$agent_pembro_mixed +
      post_ecog$beta_ipi_nivo[i] * dat_ecog$agent_ipi_nivo +
      post_ecog$beta_ecog[i] * dat_ecog$ecog_23
  )
  
  y_rep <- rbinom(dat_ecog$N, size = 1, prob = p)
  mean(y_rep)
})

pp_df_ecog <- tibble(
  simulated_response_rate = pp_rates_ecog
)

ggplot(pp_df_ecog, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(xintercept = observed_rate_ecog, color = "red", linewidth = 1.2, linetype = "dashed") +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: ECOG Model",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

---

19 Weakly Informative Prior

---

# Weakly informative prior check for the full ORR model.
# This section does NOT rebuild the model one parameter at a time.
# Instead, it validates the final assembled model under the new primary prior.
#
# Goal:
# 1. Check whether the weakly informative prior produces sensible prior predictions
# 2. Fit the full model to simulated data
# 3. Confirm that the posterior still recovers the true values reasonably well
# 4. Confirm that the model can reproduce the observed response structure

19.1 Step 1: define weakly informative prior centers

alpha_mu_weak <- qlogis(0.40)

# Main change: weakly informative dose prior centered modestly positive
beta_dose_mu_weak <- 0.10

# Other priors kept as before unless there is a strong reason to change them
beta_age_mu_weak <- 0
beta_imm_mu_weak <- -0.8
beta_conj_mu_weak <- -2.3
beta_other_mu_weak <- 0
beta_unknown_mu_weak <- 0
beta_stage_III_mu_weak <- 0
beta_stage_IV_mu_weak <- 0
beta_stage_unstaged_mu_weak <- 0
beta_pembro_q3_mu_weak <- 0
beta_pembro_q6_mu_weak <- 0
beta_pembro_mixed_mu_weak <- 0
beta_ipi_nivo_mu_weak <- 0.4
beta_ecog_mu_weak <- -0.3

19.2 Step 2: prior predictive check for the full model

set.seed(123)

n_prior <- 4000

prior_draws_full_weak <- tibble(
  alpha = rnorm(n_prior, mean = alpha_mu_weak, sd = 1.5),
  beta_dose = rnorm(n_prior, mean = beta_dose_mu_weak, sd = 0.12),
  beta_age = rnorm(n_prior, mean = beta_age_mu_weak, sd = 0.02),
  beta_imm = rnorm(n_prior, mean = beta_imm_mu_weak, sd = 0.2),
  beta_conj = rnorm(n_prior, mean = beta_conj_mu_weak, sd = 0.5),
  beta_other = rnorm(n_prior, mean = beta_other_mu_weak, sd = 0.3),
  beta_unknown = rnorm(n_prior, mean = beta_unknown_mu_weak, sd = 0.3),
  beta_stage_III = rnorm(n_prior, mean = beta_stage_III_mu_weak, sd = 0.3),
  beta_stage_IV = rnorm(n_prior, mean = beta_stage_IV_mu_weak, sd = 0.3),
  beta_stage_unstaged = rnorm(n_prior, mean = beta_stage_unstaged_mu_weak, sd = 0.3),
  beta_pembro_q3 = rnorm(n_prior, mean = beta_pembro_q3_mu_weak, sd = 0.3),
  beta_pembro_q6 = rnorm(n_prior, mean = beta_pembro_q6_mu_weak, sd = 0.3),
  beta_pembro_mixed = rnorm(n_prior, mean = beta_pembro_mixed_mu_weak, sd = 0.3),
  beta_ipi_nivo = rnorm(n_prior, mean = beta_ipi_nivo_mu_weak, sd = 0.3),
  beta_ecog = rnorm(n_prior, mean = beta_ecog_mu_weak, sd = 0.3)
) |>
  mutate(
    # Reference patient:
    # 1 dose, age 76, not immunosuppressed, Head/Neck, Stage I-II,
    # Cemiplimab, ECOG 0-1
    p_dose1 = plogis(alpha),
    p_dose2 = plogis(alpha + beta_dose),
    p_dose4 = plogis(alpha + beta_dose * 3),
    p_dose8 = plogis(alpha + beta_dose * 7)
  )

prior_full_weak_long <- bind_rows(
  prior_draws_full_weak |> transmute(dose_group = "1 dose", p = p_dose1),
  prior_draws_full_weak |> transmute(dose_group = "2 doses", p = p_dose2),
  prior_draws_full_weak |> transmute(dose_group = "4 doses", p = p_dose4),
  prior_draws_full_weak |> transmute(dose_group = "8 doses", p = p_dose8)
) |>
  mutate(
    dose_group = factor(dose_group, levels = c("1 dose", "2 doses", "4 doses", "8 doses"))
  )

set.seed(123)

n_draws <- 200

# Weakly informative priors
alpha_prior <- rnorm(n_draws, mean = qlogis(0.40), sd = 1.5)
beta_dose_prior <- rnorm(n_draws, mean = 0.10, sd = 0.12)

num_doses <- 1:15

prior_curves_weak <- purrr::map_dfr(seq_len(n_draws), function(i) {
  tibble(
    draw = i,
    num_doses = num_doses,
    dose_minus_1 = num_doses - 1,
    p = plogis(alpha_prior[i] + beta_dose_prior[i] * dose_minus_1)
  )
})

prior_curve_summary_weak <- prior_curves_weak |>
  dplyr::group_by(num_doses) |>
  dplyr::summarise(
    p_median = median(p),
    p_mean = mean(p),
    p_lower_50 = quantile(p, 0.25),
    p_upper_50 = quantile(p, 0.75),
    p_lower_89 = quantile(p, 0.055),
    p_upper_89 = quantile(p, 0.945),
    .groups = "drop"
  )
plot_prior_curves_weak <-
  ggplot() +
  geom_line(
    data = prior_curves_weak,
    aes(x = num_doses, y = p, group = draw),
    alpha = 0.08,
    color = "steelblue"
  ) +
  geom_ribbon(
    data = prior_curve_summary_weak,
    aes(x = num_doses, ymin = p_lower_89, ymax = p_upper_89),
    fill = "steelblue",
    alpha = 0.12
  ) +
  geom_ribbon(
    data = prior_curve_summary_weak,
    aes(x = num_doses, ymin = p_lower_50, ymax = p_upper_50),
    fill = "steelblue",
    alpha = 0.22
  ) +
  geom_line(
    data = prior_curve_summary_weak,
    aes(x = num_doses, y = p_median),
    linewidth = 1.3,
    color = "navy"
  ) +
  scale_y_continuous(
    limits = c(0, 1)
  ) +
  scale_x_continuous(
    breaks = seq(1, 15, by = 1)
  ) +
  labs(
    title = "Prior Predictive Dose–Response Curves",
    subtitle = "Weakly informative prior (β_dose ~ Normal(0.1, 0.12))",
    x = "Number of doses",
    y = "Response probability"
  ) +
  theme_minimal(base_size = 13) +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    panel.grid.minor = element_blank()
  )

plot_prior_curves_weak

ggplot(prior_full_weak_long, aes(x = dose_group, y = p, fill = dose_group)) +
  geom_violin(alpha = 0.5, width = 0.9, color = NA) +
  stat_summary(fun = median, geom = "point", size = 2, color = "black") +
  stat_summary(
    fun.data = median_hilow,
    fun.args = list(conf.int = 0.8),
    geom = "errorbar",
    width = 0.15,
    linewidth = 0.8,
    color = "black"
  ) +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Weakly Informative Prior Predictive Response by Dose",
    subtitle = "Reference patient: age 76, not immunosuppressed, Head/Neck, Stage I-II, Cemiplimab, ECOG 0-1",
    x = NULL,
    y = "Response probability"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    legend.position = "none"
  )

dat_ecog_weak <- list(
  N = nrow(d_sim_ecog),
  y = d_sim_ecog$y,
  x = d_sim_ecog$dose_minus_1,
  z = d_sim_ecog$age_centered,
  w = d_sim_ecog$immunosuppressed,
  loc_conj = d_sim_ecog$loc_conj,
  loc_other = d_sim_ecog$loc_other,
  loc_unknown = d_sim_ecog$loc_unknown,
  stage_III = d_sim_ecog$stage_III,
  stage_IV = d_sim_ecog$stage_IV,
  stage_unstaged = d_sim_ecog$stage_unstaged,
  agent_pembro_q3 = d_sim_ecog$agent_pembro_q3,
  agent_pembro_q6 = d_sim_ecog$agent_pembro_q6,
  agent_pembro_mixed = d_sim_ecog$agent_pembro_mixed,
  agent_ipi_nivo = d_sim_ecog$agent_ipi_nivo,
  ecog_23 = d_sim_ecog$ecog_23,
  alpha_mu = alpha_mu_weak,
  beta_dose_mu = beta_dose_mu_weak,
  beta_age_mu = beta_age_mu_weak,
  beta_imm_mu = beta_imm_mu_weak,
  beta_conj_mu = beta_conj_mu_weak,
  beta_other_mu = beta_other_mu_weak,
  beta_unknown_mu = beta_unknown_mu_weak,
  beta_stage_III_mu = beta_stage_III_mu_weak,
  beta_stage_IV_mu = beta_stage_IV_mu_weak,
  beta_stage_unstaged_mu = beta_stage_unstaged_mu_weak,
  beta_pembro_q3_mu = beta_pembro_q3_mu_weak,
  beta_pembro_q6_mu = beta_pembro_q6_mu_weak,
  beta_pembro_mixed_mu = beta_pembro_mixed_mu_weak,
  beta_ipi_nivo_mu = beta_ipi_nivo_mu_weak,
  beta_ecog_mu = beta_ecog_mu_weak
)

19.3 Step 4: fit the full weak-prior model

m_ecog_weak <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_dose * x +
      beta_age * z +
      beta_imm * w +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged +
      beta_pembro_q3 * agent_pembro_q3 +
      beta_pembro_q6 * agent_pembro_q6 +
      beta_pembro_mixed * agent_pembro_mixed +
      beta_ipi_nivo * agent_ipi_nivo +
      beta_ecog * ecog_23,

    alpha ~ normal(alpha_mu, 1.5),
    beta_dose ~ normal(beta_dose_mu, 0.3),
    beta_age ~ normal(beta_age_mu, 0.02),
    beta_imm ~ normal(beta_imm_mu, 0.2),
    beta_conj ~ normal(beta_conj_mu, 0.5),
    beta_other ~ normal(beta_other_mu, 0.3),
    beta_unknown ~ normal(beta_unknown_mu, 0.3),
    beta_stage_III ~ normal(beta_stage_III_mu, 0.3),
    beta_stage_IV ~ normal(beta_stage_IV_mu, 0.3),
    beta_stage_unstaged ~ normal(beta_stage_unstaged_mu, 0.3),
    beta_pembro_q3 ~ normal(beta_pembro_q3_mu, 0.3),
    beta_pembro_q6 ~ normal(beta_pembro_q6_mu, 0.3),
    beta_pembro_mixed ~ normal(beta_pembro_mixed_mu, 0.3),
    beta_ipi_nivo ~ normal(beta_ipi_nivo_mu, 0.3),
    beta_ecog ~ normal(beta_ecog_mu, 0.3)
  ),
  data = dat_ecog_weak,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 finished in 1.0 seconds.
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 1.0 seconds.
Chain 3 finished in 1.0 seconds.
Chain 4 finished in 1.0 seconds.

All 4 chains finished successfully.
Mean chain execution time: 1.0 seconds.
Total execution time: 1.1 seconds.

19.3.1 Step 5: Check recoverry of the truth

precis(m_ecog_weak, depth = 2)

                            mean         sd        5.5%        94.5%     rhat
alpha               -0.702012928 0.27738280 -1.13686034 -0.265494704 1.000067
beta_dose            0.033964684 0.03420844 -0.01993183  0.088788472 1.000338
beta_age            -0.007092322 0.01078360 -0.02443042  0.009905495 1.002007
beta_imm            -0.864581996 0.19345730 -1.18283521 -0.557291807 1.001121
beta_conj           -2.483663245 0.45171696 -3.21032879 -1.771299178 1.000600
beta_other           0.181878990 0.26917986 -0.24358748  0.615369242 1.000285
beta_unknown        -0.016652375 0.28337461 -0.47240362  0.430339646 1.000292
beta_stage_III      -0.226944618 0.24153197 -0.61735448  0.157383229 1.000505
beta_stage_IV        0.185708318 0.23825521 -0.18888995  0.573674831 1.000919
beta_stage_unstaged  0.169783964 0.26765251 -0.27533175  0.589843203 1.000927
beta_pembro_q3       0.057824916 0.23969573 -0.33094691  0.448085145 1.000370
beta_pembro_q6       0.037707640 0.26375281 -0.37590906  0.467954700 1.000146
beta_pembro_mixed   -0.032913455 0.27417112 -0.47987375  0.403111718 1.003226
beta_ipi_nivo        0.237081247 0.27486510 -0.21428609  0.674505414 1.000654
beta_ecog           -0.227244159 0.22470798 -0.58108012  0.130848043 1.002046
                    ess_bulk
alpha               4365.492
beta_dose           7113.873
beta_age            7325.854
beta_imm            7620.567
beta_conj           7639.583
beta_other          6776.791
beta_unknown        7528.667
beta_stage_III      6195.758
beta_stage_IV       5157.126
beta_stage_unstaged 8031.801
beta_pembro_q3      6537.679
beta_pembro_q6      7608.009
beta_pembro_mixed   8719.074
beta_ipi_nivo       8442.951
beta_ecog           6891.426

19.4 Step 6: compare prior vs posterior for key parameters

post_ecog_weak <- extract.samples(m_ecog_weak)

plot_df_dose_weak <- bind_rows(
  tibble(value = rnorm(4000, beta_dose_mu_weak, 0.3), source = "Prior", term = "Dose"),
  tibble(value = post_ecog_weak$beta_dose, source = "Posterior", term = "Dose")
)

plot_df_ipi_weak <- bind_rows(
  tibble(value = rnorm(4000, beta_ipi_nivo_mu_weak, 0.3), source = "Prior", term = "Ipi_Nivo"),
  tibble(value = post_ecog_weak$beta_ipi_nivo, source = "Posterior", term = "Ipi_Nivo")
)

plot_df_ecog_weak <- bind_rows(
  tibble(value = rnorm(4000, beta_ecog_mu_weak, 0.3), source = "Prior", term = "ECOG"),
  tibble(value = post_ecog_weak$beta_ecog, source = "Posterior", term = "ECOG")
)

plot_df_key_weak <- bind_rows(
  plot_df_dose_weak,
  plot_df_ipi_weak,
  plot_df_ecog_weak
)

ggplot(plot_df_key_weak, aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  facet_wrap(~ term, scales = "free") +
  geom_vline(xintercept = 0, linetype = "dashed") +
  labs(
    title = "Weakly Informative Prior vs Posterior",
    subtitle = "Key parameters from the full model",
    x = "Coefficient value",
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

19.5 Step 7: posterior predictive check

observed_rate_ecog_weak <- mean(d_sim_ecog$y)

pp_rates_ecog_weak <- sapply(seq_along(post_ecog_weak$alpha), function(i) {
  p <- plogis(
    post_ecog_weak$alpha[i] +
      post_ecog_weak$beta_dose[i] * dat_ecog_weak$x +
      post_ecog_weak$beta_age[i] * dat_ecog_weak$z +
      post_ecog_weak$beta_imm[i] * dat_ecog_weak$w +
      post_ecog_weak$beta_conj[i] * dat_ecog_weak$loc_conj +
      post_ecog_weak$beta_other[i] * dat_ecog_weak$loc_other +
      post_ecog_weak$beta_unknown[i] * dat_ecog_weak$loc_unknown +
      post_ecog_weak$beta_stage_III[i] * dat_ecog_weak$stage_III +
      post_ecog_weak$beta_stage_IV[i] * dat_ecog_weak$stage_IV +
      post_ecog_weak$beta_stage_unstaged[i] * dat_ecog_weak$stage_unstaged +
      post_ecog_weak$beta_pembro_q3[i] * dat_ecog_weak$agent_pembro_q3 +
      post_ecog_weak$beta_pembro_q6[i] * dat_ecog_weak$agent_pembro_q6 +
      post_ecog_weak$beta_pembro_mixed[i] * dat_ecog_weak$agent_pembro_mixed +
      post_ecog_weak$beta_ipi_nivo[i] * dat_ecog_weak$agent_ipi_nivo +
      post_ecog_weak$beta_ecog[i] * dat_ecog_weak$ecog_23
  )

  y_rep <- rbinom(dat_ecog_weak$N, size = 1, prob = p)
  mean(y_rep)
})

pp_df_ecog_weak <- tibble(
  simulated_response_rate = pp_rates_ecog_weak
)

ggplot(pp_df_ecog_weak, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(
    xintercept = observed_rate_ecog_weak,
    color = "red",
    linewidth = 1.2,
    linetype = "dashed"
  ) +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Full Weak-Prior Model",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

---

20 Simulation Based Validation of True Effect

20.1 Step 1: define the true positive effect

alpha_true <- qlogis(0.40)
beta_dose_true <- 0.20   # modest positive dose effect
beta_age_true <- -0.01
beta_imm_true <- -0.8
beta_conj_true <- -2.3
beta_other_true <- 0
beta_unknown_true <- 0
beta_stage_III_true <- 0
beta_stage_IV_true <- 0
beta_stage_unstaged_true <- 0
beta_pembro_q3_true <- 0
beta_pembro_q6_true <- 0
beta_pembro_mixed_true <- 0
beta_ipi_nivo_true <- 0.4
beta_ecog_true <- -0.3

20.1.1 Step 2: simulate the outcome with a positive dose effect

d_sim_ecog_pos <- d_sim_ecog |>
  mutate(
    p = plogis(
      alpha_true +
        beta_dose_true * dose_minus_1 +
        beta_age_true * age_centered +
        beta_imm_true * immunosuppressed +
        beta_conj_true * loc_conj +
        beta_other_true * loc_other +
        beta_unknown_true * loc_unknown +
        beta_stage_III_true * stage_III +
        beta_stage_IV_true * stage_IV +
        beta_stage_unstaged_true * stage_unstaged +
        beta_pembro_q3_true * agent_pembro_q3 +
        beta_pembro_q6_true * agent_pembro_q6 +
        beta_pembro_mixed_true * agent_pembro_mixed +
        beta_ipi_nivo_true * agent_ipi_nivo +
        beta_ecog_true * ecog_23
    ),
    y = rbinom(n(), size = 1, prob = p)
  )

cat("\n--- Simulated Outcome Diagnostics: Positive Dose Effect ---\n")

--- Simulated Outcome Diagnostics: Positive Dose Effect ---

cat("Number of rows:", nrow(d_sim_ecog_pos), "\n")

Number of rows: 189 

cat("Range of y:", paste(range(d_sim_ecog_pos$y), collapse = " to "), "\n")

Range of y: 0 to 1 

cat("Mean response rate:", round(mean(d_sim_ecog_pos$y), 3), "\n\n")

Mean response rate: 0.492 

cat("Outcome counts:\n")

Outcome counts:

print(table(d_sim_ecog_pos$y))

 0  1 
96 93 

20.2 Step 3: build the data list using the weak prior centers

dat_ecog_weak_pos <- list(
  N = nrow(d_sim_ecog_pos),
  y = d_sim_ecog_pos$y,
  x = d_sim_ecog_pos$dose_minus_1,
  z = d_sim_ecog_pos$age_centered,
  w = d_sim_ecog_pos$immunosuppressed,
  loc_conj = d_sim_ecog_pos$loc_conj,
  loc_other = d_sim_ecog_pos$loc_other,
  loc_unknown = d_sim_ecog_pos$loc_unknown,
  stage_III = d_sim_ecog_pos$stage_III,
  stage_IV = d_sim_ecog_pos$stage_IV,
  stage_unstaged = d_sim_ecog_pos$stage_unstaged,
  agent_pembro_q3 = d_sim_ecog_pos$agent_pembro_q3,
  agent_pembro_q6 = d_sim_ecog_pos$agent_pembro_q6,
  agent_pembro_mixed = d_sim_ecog_pos$agent_pembro_mixed,
  agent_ipi_nivo = d_sim_ecog_pos$agent_ipi_nivo,
  ecog_23 = d_sim_ecog_pos$ecog_23,
  alpha_mu = alpha_mu_weak,
  beta_dose_mu = beta_dose_mu_weak,
  beta_age_mu = beta_age_mu_weak,
  beta_imm_mu = beta_imm_mu_weak,
  beta_conj_mu = beta_conj_mu_weak,
  beta_other_mu = beta_other_mu_weak,
  beta_unknown_mu = beta_unknown_mu_weak,
  beta_stage_III_mu = beta_stage_III_mu_weak,
  beta_stage_IV_mu = beta_stage_IV_mu_weak,
  beta_stage_unstaged_mu = beta_stage_unstaged_mu_weak,
  beta_pembro_q3_mu = beta_pembro_q3_mu_weak,
  beta_pembro_q6_mu = beta_pembro_q6_mu_weak,
  beta_pembro_mixed_mu = beta_pembro_mixed_mu_weak,
  beta_ipi_nivo_mu = beta_ipi_nivo_mu_weak,
  beta_ecog_mu = beta_ecog_mu_weak
)

20.2.1 Step 4: fit the weak-prior full model to the positive-effect data

m_ecog_weak_pos <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_dose * x +
      beta_age * z +
      beta_imm * w +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged +
      beta_pembro_q3 * agent_pembro_q3 +
      beta_pembro_q6 * agent_pembro_q6 +
      beta_pembro_mixed * agent_pembro_mixed +
      beta_ipi_nivo * agent_ipi_nivo +
      beta_ecog * ecog_23,

    alpha ~ normal(alpha_mu, 1.5),
    beta_dose ~ normal(beta_dose_mu, 0.3),
    beta_age ~ normal(beta_age_mu, 0.02),
    beta_imm ~ normal(beta_imm_mu, 0.2),
    beta_conj ~ normal(beta_conj_mu, 0.5),
    beta_other ~ normal(beta_other_mu, 0.3),
    beta_unknown ~ normal(beta_unknown_mu, 0.3),
    beta_stage_III ~ normal(beta_stage_III_mu, 0.3),
    beta_stage_IV ~ normal(beta_stage_IV_mu, 0.3),
    beta_stage_unstaged ~ normal(beta_stage_unstaged_mu, 0.3),
    beta_pembro_q3 ~ normal(beta_pembro_q3_mu, 0.3),
    beta_pembro_q6 ~ normal(beta_pembro_q6_mu, 0.3),
    beta_pembro_mixed ~ normal(beta_pembro_mixed_mu, 0.3),
    beta_ipi_nivo ~ normal(beta_ipi_nivo_mu, 0.3),
    beta_ecog ~ normal(beta_ecog_mu, 0.3)
  ),
  data = dat_ecog_weak_pos,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 finished in 1.0 seconds.
Chain 2 finished in 1.0 seconds.
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 finished in 1.0 seconds.
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 finished in 1.1 seconds.

All 4 chains finished successfully.
Mean chain execution time: 1.0 seconds.
Total execution time: 1.3 seconds.

20.2.2 Step 5: check whether it recovers the positive effect

precis(m_ecog_weak_pos, depth = 2)

                           mean         sd        5.5%        94.5%      rhat
alpha               -0.21985687 0.28510142 -0.68383494  0.239202833 1.0011568
beta_dose            0.15273080 0.04891639  0.07704507  0.233944689 1.0006629
beta_age            -0.01604176 0.01073718 -0.03315521  0.001184203 1.0003159
beta_imm            -0.83414857 0.18904599 -1.13109863 -0.528859554 1.0007132
beta_conj           -1.98348891 0.41524139 -2.66467868 -1.319740970 1.0020333
beta_other           0.09631807 0.27227459 -0.34016692  0.531905817 1.0044077
beta_unknown        -0.06782995 0.29386948 -0.52982804  0.398855705 1.0026590
beta_stage_III      -0.26154426 0.24078671 -0.64560652  0.123128998 0.9995618
beta_stage_IV        0.18639291 0.23655601 -0.19160935  0.566019542 1.0004330
beta_stage_unstaged -0.01719342 0.26601740 -0.44375302  0.404025208 1.0000016
beta_pembro_q3      -0.06278889 0.24033167 -0.45694474  0.315064840 1.0008564
beta_pembro_q6       0.13713669 0.26437409 -0.28790556  0.553506355 1.0004928
beta_pembro_mixed    0.03269866 0.27849245 -0.41077302  0.491408674 1.0010455
beta_ipi_nivo        0.46146527 0.26829793  0.03732629  0.884355224 0.9997392
beta_ecog           -0.22008271 0.22364278 -0.57754690  0.133673276 1.0000987
                    ess_bulk
alpha               4468.478
beta_dose           6506.795
beta_age            7353.994
beta_imm            8907.457
beta_conj           7897.454
beta_other          7603.991
beta_unknown        7230.146
beta_stage_III      5589.965
beta_stage_IV       5823.369
beta_stage_unstaged 6636.550
beta_pembro_q3      7041.319
beta_pembro_q6      7712.528
beta_pembro_mixed   8124.207
beta_ipi_nivo       7528.360
beta_ecog           6803.976

The key target in this simulation is the dose effect, which was set to (_{}^{} = 0.10). The posterior should therefore recover a modest positive coefficient centered near 0.10, with remaining uncertainty reflecting the sample size and the multivariable structure of the model.

20.2.3 Step 6: compare prior vs posterior for the dose effect

post_ecog_weak_pos <- extract.samples(m_ecog_weak_pos)

plot_df_dose_weak_pos <- bind_rows(
  tibble(value = rnorm(4000, beta_dose_mu_weak, 0.3), source = "Prior"),
  tibble(value = post_ecog_weak_pos$beta_dose, source = "Posterior")
)

ggplot(plot_df_dose_weak_pos, aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.25, linewidth = 1) +
  geom_vline(xintercept = 0, linetype = "dashed") +
  geom_vline(xintercept = beta_dose_true, linetype = "dotted", color = "black") +
  labs(
    title = "Prior vs Posterior for Positive Dose Effect",
    subtitle = "Dotted line = true simulated value",
    x = expression(beta[dose]),
    y = "Density"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

20.2.4 Step 7: posterior predictive check

observed_rate_ecog_weak_pos <- mean(d_sim_ecog_pos$y)

pp_rates_ecog_weak_pos <- sapply(seq_along(post_ecog_weak_pos$alpha), function(i) {
  p <- plogis(
    post_ecog_weak_pos$alpha[i] +
      post_ecog_weak_pos$beta_dose[i] * dat_ecog_weak_pos$x +
      post_ecog_weak_pos$beta_age[i] * dat_ecog_weak_pos$z +
      post_ecog_weak_pos$beta_imm[i] * dat_ecog_weak_pos$w +
      post_ecog_weak_pos$beta_conj[i] * dat_ecog_weak_pos$loc_conj +
      post_ecog_weak_pos$beta_other[i] * dat_ecog_weak_pos$loc_other +
      post_ecog_weak_pos$beta_unknown[i] * dat_ecog_weak_pos$loc_unknown +
      post_ecog_weak_pos$beta_stage_III[i] * dat_ecog_weak_pos$stage_III +
      post_ecog_weak_pos$beta_stage_IV[i] * dat_ecog_weak_pos$stage_IV +
      post_ecog_weak_pos$beta_stage_unstaged[i] * dat_ecog_weak_pos$stage_unstaged +
      post_ecog_weak_pos$beta_pembro_q3[i] * dat_ecog_weak_pos$agent_pembro_q3 +
      post_ecog_weak_pos$beta_pembro_q6[i] * dat_ecog_weak_pos$agent_pembro_q6 +
      post_ecog_weak_pos$beta_pembro_mixed[i] * dat_ecog_weak_pos$agent_pembro_mixed +
      post_ecog_weak_pos$beta_ipi_nivo[i] * dat_ecog_weak_pos$agent_ipi_nivo +
      post_ecog_weak_pos$beta_ecog[i] * dat_ecog_weak_pos$ecog_23
  )

  y_rep <- rbinom(dat_ecog_weak_pos$N, size = 1, prob = p)
  mean(y_rep)
})

pp_df_ecog_weak_pos <- tibble(
  simulated_response_rate = pp_rates_ecog_weak_pos
)

ggplot(pp_df_ecog_weak_pos, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(
    xintercept = observed_rate_ecog_weak_pos,
    color = "red",
    linewidth = 1.2,
    linetype = "dashed"
  ) +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Positive-Effect Simulation",
    subtitle = "Red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

sim_null_summary <- precis(m_ecog_weak, depth = 2)
sim_pos_summary  <- precis(m_ecog_weak_pos, depth = 2)

sim_null_beta <- sim_null_summary["beta_dose", "mean"]
sim_pos_beta  <- sim_pos_summary["beta_dose", "mean"]

sim_null_p_gt_0 <- mean(extract.samples(m_ecog_weak)$beta_dose > 0)
sim_pos_p_gt_0  <- mean(extract.samples(m_ecog_weak_pos)$beta_dose > 0)
#| label: simulation-summary-formatting

sim_null_prob <- round(sim_null_p_gt_0 * 100, 1)

sim_pos_prob <- ifelse(
  sim_pos_p_gt_0 > 0.999,
  ">99.9",
  ifelse(sim_pos_p_gt_0 > 0.99,
         ">99",
         round(sim_pos_p_gt_0 * 100, 1))
)

Under null conditions (true β = 0, where β denotes the log-odds increase in response per additional dose using the weakly informative prior), the model recovered β ≈ 0.034, with posterior probability P(β > 0) = 83.5%, appropriately reflecting uncertainty around the null. Under moderate positive-effect conditions (true β = 0.20), the model recovered β ≈ 0.153, with posterior probability P(β > 0) >99.9%. Together, these simulations suggest that the uncertainty observed in the real-world dose–response analyses reflects genuine data limitations rather than inadequate model sensitivity.

20.2.5 Step 8:

doses <- 0:14

new_data_linear_validation <- data.frame(
  x = doses,
  z = 0,
  w = 0,
  loc_conj = 0,
  loc_other = 0,
  loc_unknown = 0,
  stage_III = 0,
  stage_IV = 0,
  stage_unstaged = 0,
  agent_pembro_q3 = 0,
  agent_pembro_q6 = 0,
  agent_pembro_mixed = 0,
  agent_ipi_nivo = 0,
  ecog_23 = 0
)

# Null-effect simulation
p_linear_null <- link(m_ecog_weak, data = new_data_linear_validation)

plot_df_linear_null <- tibble(
  dose_number = doses + 1,
  mean_p = apply(p_linear_null, 2, mean),
  lower = apply(p_linear_null, 2, PI, 0.89)[1, ],
  upper = apply(p_linear_null, 2, PI, 0.89)[2, ],
  scenario = "Null effect (true β = 0)"
)

# Positive-effect simulation
p_linear_pos <- link(m_ecog_weak_pos, data = new_data_linear_validation)

plot_df_linear_pos <- tibble(
  dose_number = doses + 1,
  mean_p = apply(p_linear_pos, 2, mean),
  lower = apply(p_linear_pos, 2, PI, 0.89)[1, ],
  upper = apply(p_linear_pos, 2, PI, 0.89)[2, ],
  scenario = "Positive effect (true β = 0.20)"
)

plot_df_linear_validation <- bind_rows(
  plot_df_linear_null,
  plot_df_linear_pos
)

ggplot(
  plot_df_linear_validation,
  aes(x = dose_number, y = mean_p)
) +
  geom_ribbon(
    aes(ymin = lower, ymax = upper),
    fill = "steelblue",
    alpha = 0.18
  ) +
  geom_line(
    linewidth = 1.2,
    color = "steelblue4"
  ) +
  geom_point(
    size = 2.2,
    shape = 21,
    stroke = 0.8,
    fill = "white",
    color = "steelblue4"
  ) +
  facet_wrap(~ scenario, ncol = 2) +
  scale_y_continuous(
    limits = c(0, 1),
    breaks = seq(0, 1, by = 0.1),
    labels = scales::percent_format(accuracy = 1)
  ) +
  scale_x_continuous(
    breaks = 1:15
  ) +
  labs(
    title = "Posterior predicted response probability by dose",
    subtitle = "Linear dose model fit to simulated data under null and known positive-effect scenarios",
    x = "Number of doses",
    y = "Predicted response probability"
  ) +
  theme_minimal(base_size = 13) +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    strip.text = element_text(face = "bold"),
    panel.grid.minor = element_blank()
  )

---

21 Add Dose Intensity Variables to our Model

21.1 Simulate capped and uncapped dose-intensity variables

set.seed(123)

N <- 189

observed_doses <- c(
  rep(1, 11), rep(2, 79), rep(3, 19), rep(4, 18), rep(5, 11),
  rep(6, 9), rep(7, 6), rep(8, 9), rep(9, 5), rep(10, 1),
  rep(11, 3), rep(13, 2), rep(14, 3), rep(15, 2), rep(16, 3),
  rep(20, 1), rep(28, 1), rep(43, 1)
)

d_sim_di <- tibble(
  patient_id = 1:N,
  num_doses = sample(observed_doses, N, replace = TRUE),
  age = rnorm(N, mean = 76, sd = 12),
  immunosuppressed = rbinom(N, size = 1, prob = 0.17),
  location_condensed = sample(
    c("Head/Neck", "Conjunctiva", "Other", "Unknown Primary"),
    N,
    replace = TRUE,
    prob = c(0.80, 0.08, 0.08, 0.04)
  ),
  agent_schedule = sample(
    c("cemiplimab", "pembro_q3", "pembro_q6", "pembro_mixed", "Ipi-nivo"),
    N,
    replace = TRUE,
    prob = c(0.55, 0.18, 0.10, 0.07, 0.10)
  )
) |>
  mutate(
    dose_minus_1 = num_doses - 1,
    age_centered = age - 76,
    loc_conj = as.integer(location_condensed == "Conjunctiva"),
    loc_other = as.integer(location_condensed == "Other"),
    loc_unknown = as.integer(location_condensed == "Unknown Primary"),
    agent_pembro_q3 = as.integer(agent_schedule == "pembro_q3"),
    agent_pembro_q6 = as.integer(agent_schedule == "pembro_q6"),
    agent_pembro_mixed = as.integer(agent_schedule == "pembro_mixed"),
    agent_ipi_nivo = as.integer(agent_schedule == "Ipi-nivo")
  ) |>
  rowwise() |>
  mutate(
    stage_condensed = if_else(
      location_condensed == "Conjunctiva",
      sample(c("Stage III", "Stage IV", "Unstaged"), 1, prob = c(0.30, 0.50, 0.20)),
      sample(c("Stage I-II", "Stage III", "Stage IV", "Unstaged"), 1,
             prob = c(0.08, 0.38, 0.42, 0.12))
    )
  ) |>
  ungroup() |>
  mutate(
    stage_III = as.integer(stage_condensed == "Stage III"),
    stage_IV = as.integer(stage_condensed == "Stage IV"),
    stage_unstaged = as.integer(stage_condensed == "Unstaged")
  )

21.1.0.1 Simulate ECOG as before

d_sim_di <- d_sim_di |>
  mutate(
    ps_score =
      scale(age)[, 1] * 0.3 +
      ifelse(immunosuppressed == 1, 0.5, 0) +
      case_when(
        stage_condensed == "Stage I-II" ~ -0.4,
        stage_condensed == "Stage III" ~ 0,
        stage_condensed == "Stage IV" ~ 0.5,
        stage_condensed == "Unstaged" ~ 0.1
      ) +
      rnorm(N, 0, 0.8),

    ecog = case_when(
      ps_score < -0.5 ~ 0,
      ps_score <  0.5 ~ 1,
      ps_score <  1.5 ~ 2,
      TRUE ~ 3
    ),

    ecog_condensed = if_else(ecog <= 1, "ECOG 0-1", "ECOG 2-3"),
    ecog_23 = as.integer(ecog_condensed == "ECOG 2-3")
  )

21.1.0.2 Simulate elapsed time structure and dose-intensity variables

d_sim_di <- d_sim_di |>
  mutate(
    expected_interval_days = case_when(
      agent_schedule %in% c("cemiplimab", "pembro_q3") ~ 21,
      agent_schedule == "Ipi-nivo" ~ 14,
      agent_schedule == "pembro_q6" ~ 42,
      agent_schedule == "pembro_mixed" ~ sample(c(21, 42), N, replace = TRUE)
    ),

    # Number of doses observed before response
    num_doses_pre_response = pmax(
      1,
      pmin(
        num_doses,
        round(num_doses - rpois(N, lambda = 1.5))
      )
    ),

    num_doses_recorded = num_doses,

    # Expected elapsed days
    expected_elapsed_days =
      pmax(1, num_doses_recorded - 1) * expected_interval_days,

    expected_elapsed_days_pre_response =
      pmax(1, num_doses_pre_response - 1) * expected_interval_days,

    # Simulate observed elapsed days with some delays and some compression
    observed_elapsed_days =
      expected_elapsed_days *
      exp(rnorm(N, mean = 0.05, sd = 0.25)),

    observed_elapsed_days_pre_response =
      expected_elapsed_days_pre_response *
      exp(rnorm(N, mean = 0.03, sd = 0.22)),

    # For pembrolizumab-specific interval variable
    expected_days_sum = expected_elapsed_days,
    observed_days_sum = observed_elapsed_days
  ) |>
  mutate(
    # -----------------------------
    # capped versions
    # -----------------------------
    dose_intensity_final = case_when(
      num_doses_recorded <= 1 ~ 1,
      is.na(expected_interval_days) ~ NA_real_,
      observed_elapsed_days <= 0 ~ NA_real_,
      TRUE ~ pmin(1, expected_elapsed_days / observed_elapsed_days)
    ),

    dose_intensity_pre_response = case_when(
      num_doses_pre_response <= 1 ~ 1,
      is.na(expected_interval_days) ~ NA_real_,
      observed_elapsed_days_pre_response <= 0 ~ NA_real_,
      TRUE ~ pmin(1, expected_elapsed_days_pre_response /
                    observed_elapsed_days_pre_response)
    ),

    dose_intensity_pembro_interval = case_when(
      observed_days_sum <= 0 ~ NA_real_,
      expected_days_sum <= 0 ~ NA_real_,
      TRUE ~ pmin(1, expected_days_sum / observed_days_sum)
    ),

    # -----------------------------
    # uncapped versions
    # -----------------------------
    dose_intensity_final_uncapped = case_when(
      num_doses_recorded <= 1 ~ 1,
      is.na(expected_interval_days) ~ NA_real_,
      observed_elapsed_days <= 0 ~ NA_real_,
      TRUE ~ expected_elapsed_days / observed_elapsed_days
    ),

    dose_intensity_pre_response_uncapped = case_when(
      num_doses_pre_response <= 1 ~ 1,
      is.na(expected_interval_days) ~ NA_real_,
      observed_elapsed_days_pre_response <= 0 ~ NA_real_,
      TRUE ~ expected_elapsed_days_pre_response /
        observed_elapsed_days_pre_response
    ),

    dose_intensity_pembro_interval_uncapped = case_when(
      observed_days_sum <= 0 ~ NA_real_,
      expected_days_sum <= 0 ~ NA_real_,
      TRUE ~ expected_days_sum / observed_days_sum
    )
  )

21.1.0.3 Quick diagnostics of the simulated intensity variables

d_sim_di |>
  select(
    dose_intensity_final,
    dose_intensity_pre_response,
    dose_intensity_pembro_interval,
    dose_intensity_final_uncapped,
    dose_intensity_pre_response_uncapped,
    dose_intensity_pembro_interval_uncapped
  ) |>
  summary()

 dose_intensity_final dose_intensity_pre_response
 Min.   :0.4075       Min.   :0.5871             
 1st Qu.:0.8147       1st Qu.:0.8841             
 Median :0.9753       Median :1.0000             
 Mean   :0.9021       Mean   :0.9430             
 3rd Qu.:1.0000       3rd Qu.:1.0000             
 Max.   :1.0000       Max.   :1.0000             
 dose_intensity_pembro_interval dose_intensity_final_uncapped
 Min.   :0.4075                 Min.   :0.4075               
 1st Qu.:0.8141                 1st Qu.:0.8147               
 Median :0.9677                 Median :0.9753               
 Mean   :0.8982                 Mean   :0.9909               
 3rd Qu.:1.0000                 3rd Qu.:1.1337               
 Max.   :1.0000                 Max.   :1.6963               
 dose_intensity_pre_response_uncapped dose_intensity_pembro_interval_uncapped
 Min.   :0.5871                       Min.   :0.4075                         
 1st Qu.:0.8841                       1st Qu.:0.8141                         
 Median :1.0000                       Median :0.9677                         
 Mean   :0.9799                       Mean   :0.9904                         
 3rd Qu.:1.0000                       3rd Qu.:1.1468                         
 Max.   :1.5044                       Max.   :1.6963                         

21.1.0.4 Prior setup for the primary dose-intensity sensitivity variable

21.1.0.4.1 Center both capped and uncapped versions

d_sim_di <- d_sim_di |>
  mutate(
    di_pre_capped_centered =
      dose_intensity_pre_response -
      mean(dose_intensity_pre_response, na.rm = TRUE),

    di_pre_uncapped_centered =
      dose_intensity_pre_response_uncapped -
      mean(dose_intensity_pre_response_uncapped, na.rm = TRUE)
  )

21.1.0.5 Prior predictive checks for capped vs uncapped pre-response dose intensity

Use the same weak prior for the dose-intensity coefficient:

\(𝛽_\text{DI}\) ∼ 𝑁(0.10,0.12)

21.1.0.5.1 Simulate prior curves

set.seed(123)

n_prior <- 4000

di_grid_capped <- seq(
  min(d_sim_di$di_pre_capped_centered, na.rm = TRUE),
  max(d_sim_di$di_pre_capped_centered, na.rm = TRUE),
  length.out = 60
)

di_grid_uncapped <- seq(
  min(d_sim_di$di_pre_uncapped_centered, na.rm = TRUE),
  max(d_sim_di$di_pre_uncapped_centered, na.rm = TRUE),
  length.out = 60
)

prior_draws_di <- tibble(
  alpha = rnorm(n_prior, mean = qlogis(0.40), sd = 1.5),
  beta_di = rnorm(n_prior, mean = 0.10, sd = 0.12)
)

prior_curves_di_capped <- purrr::map_dfr(seq_len(n_prior), function(i) {
  tibble(
    draw = i,
    di = di_grid_capped,
    p = plogis(prior_draws_di$alpha[i] + prior_draws_di$beta_di[i] * di),
    version = "Capped"
  )
})

prior_curves_di_uncapped <- purrr::map_dfr(seq_len(n_prior), function(i) {
  tibble(
    draw = i,
    di = di_grid_uncapped,
    p = plogis(prior_draws_di$alpha[i] + prior_draws_di$beta_di[i] * di),
    version = "Uncapped"
  )
})

prior_curves_di <- bind_rows(
  prior_curves_di_capped,
  prior_curves_di_uncapped
)

21.1.0.6 Spaghetti prior predictive plot

ggplot(prior_curves_di, aes(x = di, y = p, group = draw)) +
  geom_line(alpha = 0.03, color = "steelblue") +
  facet_wrap(~ version, scales = "free_x") +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Prior Predictive Curves for Pre-Response Dose Intensity",
    subtitle = "Weakly informative prior on the dose-intensity effect",
    x = "Centered dose intensity (ratio of expected to observed treatment interval)",
    y = "Response probability"
  ) +
  theme_minimal(base_size = 13) +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Fan/ribbon prior predictive plot

prior_curve_summary_di <- prior_curves_di |>
  group_by(version, di) |>
  summarise(
    p_median = median(p),
    p_lower_50 = quantile(p, 0.25),
    p_upper_50 = quantile(p, 0.75),
    p_lower_89 = quantile(p, 0.055),
    p_upper_89 = quantile(p, 0.945),
    .groups = "drop"
  )

ggplot(prior_curve_summary_di, aes(x = di, y = p_median)) +
  geom_ribbon(aes(ymin = p_lower_89, ymax = p_upper_89),
              fill = "steelblue", alpha = 0.15) +
  geom_ribbon(aes(ymin = p_lower_50, ymax = p_upper_50),
              fill = "steelblue", alpha = 0.30) +
  geom_line(linewidth = 1.2, color = "navy") +
  facet_wrap(~ version, scales = "free_x") +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Prior Predictive Effect of Pre-Response Dose Intensity",
    subtitle = "Median and central prior intervals",
    x = "Centered dose intensity (ratio of expected to observed treatment interval)",
    y = "Response probability"
  ) +
  theme_minimal(base_size = 13) +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

d_sim_di |>
  summarise(
    min_capped = min(dose_intensity_pre_response, na.rm = TRUE),
    max_capped = max(dose_intensity_pre_response, na.rm = TRUE),
    min_uncapped = min(dose_intensity_pre_response_uncapped, na.rm = TRUE),
    max_uncapped = max(dose_intensity_pre_response_uncapped, na.rm = TRUE)
  )

# A tibble: 1 × 4
  min_capped max_capped min_uncapped max_uncapped
       <dbl>      <dbl>        <dbl>        <dbl>
1      0.587          1        0.587         1.50

21.2 DI model validation

Step 1: set the true parameter

beta_di_true <- 0.20

Step 2: simulate outcomes using the capped variable

This keeps all the other coefficients the same and just adds the capped dose-intensity effect.

alpha_true <- qlogis(0.40)
beta_dose_true <- 0
beta_age_true <- -0.01
beta_imm_true <- -0.8
beta_conj_true <- -2.3
beta_other_true <- 0
beta_unknown_true <- 0
beta_stage_III_true <- 0
beta_stage_IV_true <- 0
beta_stage_unstaged_true <- 0
beta_pembro_q3_true <- 0
beta_pembro_q6_true <- 0
beta_pembro_mixed_true <- 0
beta_ipi_nivo_true <- 0.4
beta_ecog_true <- -0.3

d_sim_di <- d_sim_di |>
  mutate(
    p_capped = plogis(
      alpha_true +
        beta_dose_true * dose_minus_1 +
        beta_age_true * age_centered +
        beta_imm_true * immunosuppressed +
        beta_conj_true * loc_conj +
        beta_other_true * loc_other +
        beta_unknown_true * loc_unknown +
        beta_stage_III_true * stage_III +
        beta_stage_IV_true * stage_IV +
        beta_stage_unstaged_true * stage_unstaged +
        beta_pembro_q3_true * agent_pembro_q3 +
        beta_pembro_q6_true * agent_pembro_q6 +
        beta_pembro_mixed_true * agent_pembro_mixed +
        beta_ipi_nivo_true * agent_ipi_nivo +
        beta_ecog_true * ecog_23 +
        beta_di_true * di_pre_capped_centered
    ),
    y_capped = rbinom(n(), size = 1, prob = p_capped)
  )

Step 3: simulate outcomes using the uncapped variable

d_sim_di <- d_sim_di |>
  mutate(
    p_uncapped = plogis(
      alpha_true +
        beta_dose_true * dose_minus_1 +
        beta_age_true * age_centered +
        beta_imm_true * immunosuppressed +
        beta_conj_true * loc_conj +
        beta_other_true * loc_other +
        beta_unknown_true * loc_unknown +
        beta_stage_III_true * stage_III +
        beta_stage_IV_true * stage_IV +
        beta_stage_unstaged_true * stage_unstaged +
        beta_pembro_q3_true * agent_pembro_q3 +
        beta_pembro_q6_true * agent_pembro_q6 +
        beta_pembro_mixed_true * agent_pembro_mixed +
        beta_ipi_nivo_true * agent_ipi_nivo +
        beta_ecog_true * ecog_23 +
        beta_di_true * di_pre_uncapped_centered
    ),
    y_uncapped = rbinom(n(), size = 1, prob = p_uncapped)
  )

Step 4: build data lists for the two recovery models Capped

dat_di_capped <- list(
  N = nrow(d_sim_di),
  y = d_sim_di$y_capped,
  x = d_sim_di$dose_minus_1,
  z = d_sim_di$age_centered,
  w = d_sim_di$immunosuppressed,
  loc_conj = d_sim_di$loc_conj,
  loc_other = d_sim_di$loc_other,
  loc_unknown = d_sim_di$loc_unknown,
  stage_III = d_sim_di$stage_III,
  stage_IV = d_sim_di$stage_IV,
  stage_unstaged = d_sim_di$stage_unstaged,
  agent_pembro_q3 = d_sim_di$agent_pembro_q3,
  agent_pembro_q6 = d_sim_di$agent_pembro_q6,
  agent_pembro_mixed = d_sim_di$agent_pembro_mixed,
  agent_ipi_nivo = d_sim_di$agent_ipi_nivo,
  ecog_23 = d_sim_di$ecog_23,
  di = d_sim_di$di_pre_capped_centered,
  alpha_mu = qlogis(0.40)
)

Uncapped

dat_di_uncapped <- list(
  N = nrow(d_sim_di),
  y = d_sim_di$y_uncapped,
  x = d_sim_di$dose_minus_1,
  z = d_sim_di$age_centered,
  w = d_sim_di$immunosuppressed,
  loc_conj = d_sim_di$loc_conj,
  loc_other = d_sim_di$loc_other,
  loc_unknown = d_sim_di$loc_unknown,
  stage_III = d_sim_di$stage_III,
  stage_IV = d_sim_di$stage_IV,
  stage_unstaged = d_sim_di$stage_unstaged,
  agent_pembro_q3 = d_sim_di$agent_pembro_q3,
  agent_pembro_q6 = d_sim_di$agent_pembro_q6,
  agent_pembro_mixed = d_sim_di$agent_pembro_mixed,
  agent_ipi_nivo = d_sim_di$agent_ipi_nivo,
  ecog_23 = d_sim_di$ecog_23,
  di = d_sim_di$di_pre_uncapped_centered,
  alpha_mu = qlogis(0.40)
)

Step 5: fit the two recovery models

Capped model

m_di_capped_weak <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_dose * x +
      beta_age * z +
      beta_imm * w +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged +
      beta_pembro_q3 * agent_pembro_q3 +
      beta_pembro_q6 * agent_pembro_q6 +
      beta_pembro_mixed * agent_pembro_mixed +
      beta_ipi_nivo * agent_ipi_nivo +
      beta_ecog * ecog_23 +
      beta_di * di,

    alpha ~ normal(alpha_mu, 1.5),
    beta_dose ~ normal(0.10, 0.12),
    beta_age ~ normal(0, 0.02),
    beta_imm ~ normal(-0.8, 0.2),
    beta_conj ~ normal(-2.3, 0.5),
    beta_other ~ normal(0, 0.3),
    beta_unknown ~ normal(0, 0.3),
    beta_stage_III ~ normal(0, 0.3),
    beta_stage_IV ~ normal(0, 0.3),
    beta_stage_unstaged ~ normal(0, 0.3),
    beta_pembro_q3 ~ normal(0, 0.3),
    beta_pembro_q6 ~ normal(0, 0.3),
    beta_pembro_mixed ~ normal(0, 0.3),
    beta_ipi_nivo ~ normal(0.4, 0.3),
    beta_ecog ~ normal(-0.3, 0.3),
    beta_di ~ normal(0.10, 0.12)
  ),
  data = dat_di_capped,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Rejecting initial value:

Chain 4   Log probability evaluates to log(0), i.e. negative infinity.

Chain 4   Stan can't start sampling from this initial value.

Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 1.1 seconds.
Chain 2 finished in 1.1 seconds.
Chain 4 finished in 1.1 seconds.
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 finished in 1.2 seconds.

All 4 chains finished successfully.
Mean chain execution time: 1.1 seconds.
Total execution time: 1.3 seconds.

Uncapped Model

m_di_uncapped_weak <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_dose * x +
      beta_age * z +
      beta_imm * w +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged +
      beta_pembro_q3 * agent_pembro_q3 +
      beta_pembro_q6 * agent_pembro_q6 +
      beta_pembro_mixed * agent_pembro_mixed +
      beta_ipi_nivo * agent_ipi_nivo +
      beta_ecog * ecog_23 +
      beta_di * di,

    alpha ~ normal(alpha_mu, 1.5),
    beta_dose ~ normal(0.10, 0.12),
    beta_age ~ normal(0, 0.02),
    beta_imm ~ normal(-0.8, 0.2),
    beta_conj ~ normal(-2.3, 0.5),
    beta_other ~ normal(0, 0.3),
    beta_unknown ~ normal(0, 0.3),
    beta_stage_III ~ normal(0, 0.3),
    beta_stage_IV ~ normal(0, 0.3),
    beta_stage_unstaged ~ normal(0, 0.3),
    beta_pembro_q3 ~ normal(0, 0.3),
    beta_pembro_q6 ~ normal(0, 0.3),
    beta_pembro_mixed ~ normal(0, 0.3),
    beta_ipi_nivo ~ normal(0.4, 0.3),
    beta_ecog ~ normal(-0.3, 0.3),
    beta_di ~ normal(0.10, 0.12)
  ),
  data = dat_di_uncapped,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Rejecting initial value:

Chain 1   Log probability evaluates to log(0), i.e. negative infinity.

Chain 1   Stan can't start sampling from this initial value.

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 finished in 1.0 seconds.
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 finished in 1.1 seconds.
Chain 3 finished in 1.0 seconds.
Chain 4 finished in 1.0 seconds.

All 4 chains finished successfully.
Mean chain execution time: 1.0 seconds.
Total execution time: 1.2 seconds.

Step 6: compare recovery

precis(m_di_capped_weak, depth = 2)

                           mean         sd        5.5%        94.5%      rhat
alpha               -0.36680523 0.27865658 -0.81664061  0.076625123 1.0009636
beta_dose           -0.02410762 0.03524884 -0.08160509  0.030025397 1.0002916
beta_age            -0.01454955 0.01079844 -0.03189499  0.002236045 1.0035147
beta_imm            -0.79320179 0.18391222 -1.08515264 -0.500634745 1.0020839
beta_conj           -2.51637168 0.46344944 -3.25581022 -1.778740458 1.0001311
beta_other           0.09650281 0.27125748 -0.33295367  0.526483989 1.0012658
beta_unknown        -0.03246838 0.29212808 -0.50749690  0.432671765 1.0022456
beta_stage_III      -0.04867693 0.23596507 -0.42203443  0.322673963 0.9999260
beta_stage_IV        0.01079842 0.23312547 -0.35946983  0.382722541 0.9997624
beta_stage_unstaged -0.06492817 0.26440922 -0.49629868  0.350603820 1.0017138
beta_pembro_q3       0.01745497 0.24004000 -0.36401222  0.399532794 1.0028364
beta_pembro_q6       0.06177315 0.25964372 -0.34781493  0.478276247 1.0011131
beta_pembro_mixed   -0.13289477 0.26205921 -0.55134705  0.287517286 1.0028478
beta_ipi_nivo        0.39585241 0.27908442 -0.04842155  0.844304249 1.0013539
beta_ecog           -0.28931600 0.22291553 -0.64882409  0.070088323 0.9998928
beta_di              0.10456993 0.12134366 -0.08723762  0.297417089 1.0027232
                    ess_bulk
alpha               4844.707
beta_dose           7729.266
beta_age            8140.576
beta_imm            8367.010
beta_conj           8703.841
beta_other          8187.756
beta_unknown        9057.048
beta_stage_III      6057.397
beta_stage_IV       6068.193
beta_stage_unstaged 6890.841
beta_pembro_q3      7769.972
beta_pembro_q6      7905.334
beta_pembro_mixed   8654.965
beta_ipi_nivo       8907.194
beta_ecog           6997.130
beta_di             9210.732

precis(m_di_uncapped_weak, depth = 2)

                            mean         sd        5.5%        94.5%      rhat
alpha               -0.480406697 0.27086062 -0.90841319 -0.052469967 1.0017407
beta_dose            0.038435804 0.03401030 -0.01393092  0.094778553 1.0004219
beta_age            -0.008680442 0.01069394 -0.02593540  0.008461431 1.0007757
beta_imm            -0.890544418 0.19278060 -1.19606899 -0.580880951 0.9999537
beta_conj           -2.336471968 0.44114877 -3.04930548 -1.644515549 1.0015807
beta_other           0.067356815 0.26738978 -0.36112034  0.496080369 1.0028949
beta_unknown        -0.028467558 0.28438831 -0.47101775  0.424065262 1.0009493
beta_stage_III      -0.243514226 0.24041760 -0.62691782  0.140576585 1.0006134
beta_stage_IV        0.317280532 0.23344949 -0.06293127  0.690565337 1.0034505
beta_stage_unstaged -0.081655672 0.25946598 -0.49420236  0.324551299 1.0014398
beta_pembro_q3      -0.081569268 0.23987162 -0.46424953  0.304181168 0.9998997
beta_pembro_q6      -0.015563811 0.25114548 -0.42611900  0.395141631 1.0004404
beta_pembro_mixed   -0.068044014 0.27882760 -0.51604636  0.390778446 1.0032889
beta_ipi_nivo        0.480632667 0.27308678  0.04297030  0.918111745 1.0002621
beta_ecog           -0.293762253 0.22194346 -0.65015712  0.060598356 1.0026378
beta_di              0.110930496 0.11704166 -0.07332871  0.300993162 1.0014357
                    ess_bulk
alpha               4133.921
beta_dose           6899.640
beta_age            7752.146
beta_imm            7927.563
beta_conj           6379.741
beta_other          6344.542
beta_unknown        8069.826
beta_stage_III      5830.790
beta_stage_IV       5523.056
beta_stage_unstaged 7782.770
beta_pembro_q3      7241.104
beta_pembro_q6      7141.964
beta_pembro_mixed   8056.962
beta_ipi_nivo       7241.412
beta_ecog           6966.518
beta_di             6975.160

Step 7: extract posterior dose-intensity effects

post_di_capped <- extract.samples(m_di_capped_weak)
post_di_uncapped <- extract.samples(m_di_uncapped_weak)

posterior_di_capped <- post_di_capped$beta_di
posterior_di_uncapped <- post_di_uncapped$beta_di

Step 8: prior vs posterior plot with true value

plot_df_di <- bind_rows(
  tibble(value = rnorm(4000, 0.10, 0.12), source = "Prior", version = "Capped"),
  tibble(value = posterior_di_capped, source = "Posterior", version = "Capped"),
  tibble(value = rnorm(4000, 0.10, 0.12), source = "Prior", version = "Uncapped"),
  tibble(value = posterior_di_uncapped, source = "Posterior", version = "Uncapped")
)

ggplot(plot_df_di, aes(x = value, color = source, fill = source)) +
  geom_density(alpha = 0.20, linewidth = 1) +
  facet_wrap(~ version, scales = "free") +
  geom_vline(xintercept = beta_di_true, linetype = "dotted", linewidth = 1) +
  labs(
    title = "Prior vs Posterior for Dose-Intensity Effect",
    subtitle = "Dotted line = true simulated value",
    x = expression(beta[DI]),
    y = "Density"
  ) +
  theme_minimal(base_size = 13) +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Step 9: direct recovery comparison table

tibble(
  version = c("Capped", "Uncapped"),
  true_beta = beta_di_true,
  recovered_mean = c(
    mean(posterior_di_capped),
    mean(posterior_di_uncapped)
  ),
  recovered_median = c(
    median(posterior_di_capped),
    median(posterior_di_uncapped)
  ),
  lower_89 = c(
    quantile(posterior_di_capped, 0.055),
    quantile(posterior_di_uncapped, 0.055)
  ),
  upper_89 = c(
    quantile(posterior_di_capped, 0.945),
    quantile(posterior_di_uncapped, 0.945)
  ),
  p_gt_0 = c(
    mean(posterior_di_capped > 0),
    mean(posterior_di_uncapped > 0)
  )
)

# A tibble: 2 × 7
  version  true_beta recovered_mean recovered_median lower_89 upper_89 p_gt_0
  <chr>        <dbl>          <dbl>            <dbl>    <dbl>    <dbl>  <dbl>
1 Capped         0.2          0.105            0.105  -0.0872    0.297  0.802
2 Uncapped       0.2          0.111            0.110  -0.0733    0.301  0.827

---

22 Generative Modeling for Log Dose

23 Simulate Data

# Simulate data with LOG-DOSE dose–response pattern
sim_data_logdose <- d_sim_di |>
  mutate(
    
    # Center age
    age_centered = age - 76,
    
    # Log-dose transformation
    log_dose = log(num_doses),
    
    # TRUE parameter values
    beta_log_dose = 0.3,
    beta_immuno   = -0.8,
    beta_conj     = -0.6,
    beta_age      = -0.01,
    
    # Linear predictor
    eta =
      qlogis(0.40) +                     # baseline 40% response
      beta_log_dose * log_dose +
      beta_immuno * immunosuppressed +
      beta_conj * (location_condensed == "Conjunctiva") +
      beta_age * age_centered,
    
    # Convert to probability
    response_prob = plogis(eta),
    
    # Simulated response outcome
    response = rbinom(n(), 1, response_prob)
  )
colnames(sim_data_logdose)

 [1] "patient_id"                             
 [2] "num_doses"                              
 [3] "age"                                    
 [4] "immunosuppressed"                       
 [5] "location_condensed"                     
 [6] "agent_schedule"                         
 [7] "dose_minus_1"                           
 [8] "age_centered"                           
 [9] "loc_conj"                               
[10] "loc_other"                              
[11] "loc_unknown"                            
[12] "agent_pembro_q3"                        
[13] "agent_pembro_q6"                        
[14] "agent_pembro_mixed"                     
[15] "agent_ipi_nivo"                         
[16] "stage_condensed"                        
[17] "stage_III"                              
[18] "stage_IV"                               
[19] "stage_unstaged"                         
[20] "ps_score"                               
[21] "ecog"                                   
[22] "ecog_condensed"                         
[23] "ecog_23"                                
[24] "expected_interval_days"                 
[25] "num_doses_pre_response"                 
[26] "num_doses_recorded"                     
[27] "expected_elapsed_days"                  
[28] "expected_elapsed_days_pre_response"     
[29] "observed_elapsed_days"                  
[30] "observed_elapsed_days_pre_response"     
[31] "expected_days_sum"                      
[32] "observed_days_sum"                      
[33] "dose_intensity_final"                   
[34] "dose_intensity_pre_response"            
[35] "dose_intensity_pembro_interval"         
[36] "dose_intensity_final_uncapped"          
[37] "dose_intensity_pre_response_uncapped"   
[38] "dose_intensity_pembro_interval_uncapped"
[39] "di_pre_capped_centered"                 
[40] "di_pre_uncapped_centered"               
[41] "p_capped"                               
[42] "y_capped"                               
[43] "p_uncapped"                             
[44] "y_uncapped"                             
[45] "log_dose"                               
[46] "beta_log_dose"                          
[47] "beta_immuno"                            
[48] "beta_conj"                              
[49] "beta_age"                               
[50] "eta"                                    
[51] "response_prob"                          
[52] "response"                               

model_data <- sim_data_logdose |>
  select(
    patient_id,
    response,
    log_dose,
    age_centered,
    immunosuppressed,
    loc_conj,
    loc_other,
    loc_unknown,
    ecog_23,
    stage_III,
    stage_IV,
    stage_unstaged,
    agent_pembro_q3,
    agent_pembro_q6,
    agent_pembro_mixed,
    agent_ipi_nivo,
    di_pre_capped_centered
  )

glimpse(model_data)

Rows: 189
Columns: 17
$ patient_id             <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, …
$ response               <int> 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1,…
$ log_dose               <dbl> 2.0794415, 2.7725887, 0.6931472, 2.3978953, 0.6…
$ age_centered           <dbl> 2.31595423, -4.71064265, 0.08461588, -29.938025…
$ immunosuppressed       <int> 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0,…
$ loc_conj               <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0,…
$ loc_other              <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
$ loc_unknown            <int> 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0,…
$ ecog_23                <int> 0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1,…
$ stage_III              <int> 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0,…
$ stage_IV               <int> 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 0, 0, 1,…
$ stage_unstaged         <int> 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0,…
$ agent_pembro_q3        <int> 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0,…
$ agent_pembro_q6        <int> 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
$ agent_pembro_mixed     <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
$ agent_ipi_nivo         <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
$ di_pre_capped_centered <dbl> 0.004220777, -0.187904869, 0.056980039, 0.05698…

table(exp(model_data$log_dose))

 1  2  3  4  5  6  7  8  9 10 11 13 14 15 16 28 43 
10 86 20 17 10  5  6 11  6  3  4  2  4  2  1  1  1 

summary(exp(model_data$log_dose))

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  1.000   2.000   2.000   4.481   5.000  43.000 

model_data |>
  mutate(num_doses = round(exp(log_dose))) |>
  group_by(num_doses) |>
  summarise(
    n = n(),
    response_rate = mean(response),
    .groups = "drop"
  ) |>
  ggplot(aes(x = num_doses, y = response_rate)) +
  geom_point(size = 2) +
  geom_line() +
  scale_x_continuous(breaks = c(1:10, 15, 20, 28, 43)) +
  labs(
    x = "Number of doses",
    y = "Observed response rate",
    title = "Simulated response pattern by dose"
  ) +
  theme_minimal()

24 Prior predictive check

set.seed(123)

# Baseline probability
baseline_p <- 0.40
baseline_logodds <- qlogis(baseline_p)

# Prior for log-dose coefficient
n_draws <- 4000
beta_draws <- rnorm(n_draws, mean = 0.3, sd = 0.2)

# Dose range
dose_grid <- tibble(num_doses = 1:20) |>
  mutate(log_dose = log(num_doses))

# Generate prior predictive curves
prior_pred <- expand_grid(
  beta = beta_draws,
  dose_grid
) |>
  mutate(
    eta = baseline_logodds + beta * log_dose,
    prob = plogis(eta)
  )

# Summaries
prior_summary <- prior_pred |>
  group_by(num_doses) |>
  summarize(
    median = median(prob),
    lower = quantile(prob, 0.1),
    upper = quantile(prob, 0.9)
  )

# Plot
ggplot(prior_summary, aes(num_doses, median * 100)) +
  
  geom_ribbon(
    aes(
      ymin = lower * 100,
      ymax = upper * 100
    ),
    fill = "gray70",
    alpha = 0.5
  ) +
  
  geom_line(
    linewidth = 1.4,
    color = "black"
  ) +
  
  geom_hline(
  yintercept = 40,
  linetype = "dashed",
  linewidth = 0.6,
  color = "grey40"
  ) +
  
  scale_y_continuous(
    limits = c(0, 100),
    breaks = seq(0, 100, 10),
    labels = function(x) paste0(x, "%")
  ) +
  
  scale_x_continuous(
    limits = c(1, 20),
    breaks = 1:20
  ) +
  
  labs(
    x = "Number of Immunotherapy Doses",
    y = "Predicted Response Probability",
    title = "Prior Predictive Dose–Response Curve",
    subtitle  = "Under the Weakly Informative Prior"
  ) +
  
  theme_minimal(base_size = 14) +
  theme(
    plot.title = element_text(face = "bold", hjust = 0.5),
    plot.subtitle = element_text(face = "bold", hjust = 0.5)
  )

24.1 Prior predictive check for skeptical prior

set.seed(123)

baseline_p <- 0.40
baseline_logodds <- qlogis(baseline_p)

n_draws <- 4000
beta_draws_skeptical <- rnorm(n_draws, mean = 0, sd = 0.2)

dose_grid <- tibble(
  num_doses = 1:20,
  log_dose = log(num_doses)
)

prior_pred_skeptical <- tidyr::expand_grid(
  beta = beta_draws_skeptical,
  dose_grid
) |>
  mutate(
    eta = baseline_logodds + beta * log_dose,
    prob = plogis(eta)
  )

prior_summary_skeptical <- prior_pred_skeptical |>
  group_by(num_doses) |>
  summarise(
    median = median(prob),
    lower = quantile(prob, 0.10),
    upper = quantile(prob, 0.90),
    .groups = "drop"
  )

24.1.0.1 Plot

ggplot(prior_summary_skeptical, aes(num_doses, median * 100)) +
  geom_ribbon(
    aes(ymin = lower * 100, ymax = upper * 100),
    fill = "grey75",
    alpha = 0.35
  ) +
  geom_line(
    linewidth = 1.6,
    color = "black"
  ) +
  geom_hline(
    yintercept = 40,
    linetype = "dashed",
    linewidth = 0.6,
    color = "grey40"
  ) +
  scale_y_continuous(
    limits = c(0, 100),
    breaks = seq(0, 100, 10),
    labels = function(x) paste0(x, "%")
  ) +
  scale_x_continuous(
    limits = c(1, 20),
    breaks = 1:20
  ) +
  labs(
    x = "Number of Immunotherapy Doses",
    y = "Predicted Response Probability",
    title = "Prior Predictive Dose–Response Curve",
    subtitle = "Under the Skeptical Prior"
  ) +
  theme_minimal(base_size = 14) +
  theme(
    plot.title = element_text(face = "bold", hjust = 0.5),
    plot.subtitle = element_text(face = "bold", hjust = 0.5)
  )

---

25 Categorical Prior

Step 1: simulate the categorical-threshold data

## Generative Modeling for Categorical Dose

## Simulate Data
set.seed(123)

sim_data_cat <- d_sim_di |>
  mutate(
    age_centered = age - 76,

    # Dose threshold indicators
    dose_2 = as.integer(num_doses >= 2),
    dose_3 = as.integer(num_doses >= 3),
    dose_4 = as.integer(num_doses >= 4),
    dose_5plus = as.integer(num_doses >= 5),

    # TRUE parameter values
    beta_dose_2_true = 0.25,
    beta_dose_3_true = 0.15,
    beta_dose_4_true = 0.10,
    beta_dose_5plus_true = 0.05,

    beta_immuno_true = -0.8,
    beta_conj_true   = -0.6,
    beta_age_true    = -0.01,

    # Linear predictor
    eta =
      qlogis(0.40) +
      beta_dose_2_true * dose_2 +
      beta_dose_3_true * dose_3 +
      beta_dose_4_true * dose_4 +
      beta_dose_5plus_true * dose_5plus +
      beta_immuno_true * immunosuppressed +
      beta_conj_true * (location_condensed == "Conjunctiva") +
      beta_age_true * age_centered,

    response_prob = plogis(eta),
    response = rbinom(n(), 1, response_prob)
  )

colnames(sim_data_cat)

 [1] "patient_id"                             
 [2] "num_doses"                              
 [3] "age"                                    
 [4] "immunosuppressed"                       
 [5] "location_condensed"                     
 [6] "agent_schedule"                         
 [7] "dose_minus_1"                           
 [8] "age_centered"                           
 [9] "loc_conj"                               
[10] "loc_other"                              
[11] "loc_unknown"                            
[12] "agent_pembro_q3"                        
[13] "agent_pembro_q6"                        
[14] "agent_pembro_mixed"                     
[15] "agent_ipi_nivo"                         
[16] "stage_condensed"                        
[17] "stage_III"                              
[18] "stage_IV"                               
[19] "stage_unstaged"                         
[20] "ps_score"                               
[21] "ecog"                                   
[22] "ecog_condensed"                         
[23] "ecog_23"                                
[24] "expected_interval_days"                 
[25] "num_doses_pre_response"                 
[26] "num_doses_recorded"                     
[27] "expected_elapsed_days"                  
[28] "expected_elapsed_days_pre_response"     
[29] "observed_elapsed_days"                  
[30] "observed_elapsed_days_pre_response"     
[31] "expected_days_sum"                      
[32] "observed_days_sum"                      
[33] "dose_intensity_final"                   
[34] "dose_intensity_pre_response"            
[35] "dose_intensity_pembro_interval"         
[36] "dose_intensity_final_uncapped"          
[37] "dose_intensity_pre_response_uncapped"   
[38] "dose_intensity_pembro_interval_uncapped"
[39] "di_pre_capped_centered"                 
[40] "di_pre_uncapped_centered"               
[41] "p_capped"                               
[42] "y_capped"                               
[43] "p_uncapped"                             
[44] "y_uncapped"                             
[45] "dose_2"                                 
[46] "dose_3"                                 
[47] "dose_4"                                 
[48] "dose_5plus"                             
[49] "beta_dose_2_true"                       
[50] "beta_dose_3_true"                       
[51] "beta_dose_4_true"                       
[52] "beta_dose_5plus_true"                   
[53] "beta_immuno_true"                       
[54] "beta_conj_true"                         
[55] "beta_age_true"                          
[56] "eta"                                    
[57] "response_prob"                          
[58] "response"                               

Step 2: build the modeling dataset

model_data_cat <- sim_data_cat |>
  select(
    patient_id,
    response,
    num_doses,
    dose_2,
    dose_3,
    dose_4,
    dose_5plus,
    age_centered,
    immunosuppressed,
    loc_conj,
    loc_other,
    loc_unknown,
    ecog_23,
    stage_III,
    stage_IV,
    stage_unstaged,
    agent_pembro_q3,
    agent_pembro_q6,
    agent_pembro_mixed,
    agent_ipi_nivo,
    di_pre_capped_centered
  )

glimpse(model_data_cat)

Rows: 189
Columns: 21
$ patient_id             <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, …
$ response               <int> 1, 0, 0, 0, 1, 1, 0, 1, 0, 1, 1, 1, 0, 0, 0, 1,…
$ num_doses              <dbl> 8, 16, 2, 11, 2, 4, 2, 2, 4, 7, 2, 3, 3, 3, 5, …
$ dose_2                 <int> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,…
$ dose_3                 <int> 1, 1, 0, 1, 0, 1, 0, 0, 1, 1, 0, 1, 1, 1, 1, 1,…
$ dose_4                 <int> 1, 1, 0, 1, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0,…
$ dose_5plus             <int> 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0,…
$ age_centered           <dbl> 2.31595423, -4.71064265, 0.08461588, -29.938025…
$ immunosuppressed       <int> 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0,…
$ loc_conj               <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0,…
$ loc_other              <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
$ loc_unknown            <int> 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0,…
$ ecog_23                <int> 0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1,…
$ stage_III              <int> 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0,…
$ stage_IV               <int> 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 0, 0, 1,…
$ stage_unstaged         <int> 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0,…
$ agent_pembro_q3        <int> 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0,…
$ agent_pembro_q6        <int> 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
$ agent_pembro_mixed     <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
$ agent_ipi_nivo         <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
$ di_pre_capped_centered <dbl> 0.004220777, -0.187904869, 0.056980039, 0.05698…

Step 3: inspect the simulated response pattern

table(model_data_cat$num_doses)

 1  2  3  4  5  6  7  8  9 10 11 13 14 15 16 28 43 
10 86 20 17 10  5  6 11  6  3  4  2  4  2  1  1  1 

summary(model_data_cat$num_doses)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  1.000   2.000   2.000   4.481   5.000  43.000 

model_data_cat |>
  group_by(num_doses) |>
  summarise(
    n = n(),
    response_rate = mean(response),
    .groups = "drop"
  ) |>
  ggplot(aes(x = num_doses, y = response_rate)) +
  geom_point(size = 2) +
  geom_line() +
  scale_x_continuous(breaks = c(1:10, 15, 20, 28, 43)) +
  labs(
    x = "Number of doses",
    y = "Observed response rate",
    title = "Simulated response pattern by dose"
  ) +
  theme_minimal()

Prior predictive checks For the categorical model, the most natural prior predictive check is to compute predicted response probability at each dose threshold: 1 dose: intercept only 2 doses: intercept + beta_dose_2 3 doses: intercept + beta_dose_2 + beta_dose_3 4 doses: intercept + beta_dose_2 + beta_dose_3 + beta_dose_4 5+ doses: intercept + all four threshold coefficients

Step 4: weakly informative prior predictive check

set.seed(123)

n_draws <- 4000

alpha_draws_weak <- rnorm(n_draws, mean = qlogis(0.40), sd = 1)
beta2_draws_weak <- rnorm(n_draws, mean = 0.25, sd = 0.25)
beta3_draws_weak <- rnorm(n_draws, mean = 0.15, sd = 0.25)
beta4_draws_weak <- rnorm(n_draws, mean = 0.10, sd = 0.25)
beta5_draws_weak <- rnorm(n_draws, mean = 0.05, sd = 0.25)

prior_summary_cat_weak <- tibble(
  draw = 1:n_draws,
  p_1 = plogis(alpha_draws_weak),
  p_2 = plogis(alpha_draws_weak + beta2_draws_weak),
  p_3 = plogis(alpha_draws_weak + beta2_draws_weak + beta3_draws_weak),
  p_4 = plogis(alpha_draws_weak + beta2_draws_weak + beta3_draws_weak + beta4_draws_weak),
  p_5plus = plogis(alpha_draws_weak + beta2_draws_weak + beta3_draws_weak + beta4_draws_weak + beta5_draws_weak)
) |>
  tidyr::pivot_longer(
    cols = starts_with("p_"),
    names_to = "dose_group",
    values_to = "p"
  ) |>
  mutate(
    dose_group = factor(
      dose_group,
      levels = c("p_1", "p_2", "p_3", "p_4", "p_5plus"),
      labels = c("1 dose", "2 doses", "3 doses", "4 doses", "5+ doses")
    )
  ) |>
  group_by(dose_group) |>
  summarise(
    median = median(p),
    lower = quantile(p, 0.10),
    upper = quantile(p, 0.90),
    .groups = "drop"
  )

Plot

ggplot(prior_summary_cat_weak, aes(x = dose_group, y = median * 100, group = 1)) +
  geom_ribbon(
    aes(
      ymin = lower * 100,
      ymax = upper * 100
    ),
    fill = "gray70",
    alpha = 0.5
  ) +
  geom_line(linewidth = 1.4, color = "black") +
  geom_point(size = 2.5, color = "black") +
  geom_hline(
    yintercept = 40,
    linetype = "dashed",
    linewidth = 0.6,
    color = "grey40"
  ) +
  scale_y_continuous(
    limits = c(0, 100),
    breaks = seq(0, 100, 10),
    labels = function(x) paste0(x, "%")
  ) +
  labs(
    x = "Dose threshold",
    y = "Predicted Response Probability",
    title = "Prior Predictive Dose–Response Curve",
    subtitle = "Under the Weakly Informative Prior"
  ) +
  theme_minimal(base_size = 14) +
  theme(
    plot.title = element_text(face = "bold", hjust = 0.5),
    plot.subtitle = element_text(face = "bold", hjust = 0.5)
  )

Step 5: skeptical prior predictive check

set.seed(123)

n_draws <- 4000

alpha_draws_skeptical <- rnorm(n_draws, mean = qlogis(0.40), sd = 1)
beta2_draws_skeptical <- rnorm(n_draws, mean = 0, sd = 0.25)
beta3_draws_skeptical <- rnorm(n_draws, mean = 0, sd = 0.25)
beta4_draws_skeptical <- rnorm(n_draws, mean = 0, sd = 0.25)
beta5_draws_skeptical <- rnorm(n_draws, mean = 0, sd = 0.25)

prior_summary_cat_skeptical <- tibble(
  draw = 1:n_draws,
  p_1 = plogis(alpha_draws_skeptical),
  p_2 = plogis(alpha_draws_skeptical + beta2_draws_skeptical),
  p_3 = plogis(alpha_draws_skeptical + beta2_draws_skeptical + beta3_draws_skeptical),
  p_4 = plogis(alpha_draws_skeptical + beta2_draws_skeptical + beta3_draws_skeptical + beta4_draws_skeptical),
  p_5plus = plogis(alpha_draws_skeptical + beta2_draws_skeptical + beta3_draws_skeptical + beta4_draws_skeptical + beta5_draws_skeptical)
) |>
  tidyr::pivot_longer(
    cols = starts_with("p_"),
    names_to = "dose_group",
    values_to = "p"
  ) |>
  mutate(
    dose_group = factor(
      dose_group,
      levels = c("p_1", "p_2", "p_3", "p_4", "p_5plus"),
      labels = c("1 dose", "2 doses", "3 doses", "4 doses", "5+ doses")
    )
  ) |>
  group_by(dose_group) |>
  summarise(
    median = median(p),
    lower = quantile(p, 0.10),
    upper = quantile(p, 0.90),
    .groups = "drop"
  )

Plot

ggplot(prior_summary_cat_skeptical, aes(x = dose_group, y = median * 100, group = 1)) +
  geom_ribbon(
    aes(
      ymin = lower * 100,
      ymax = upper * 100
    ),
    fill = "gray70",
    alpha = 0.5
  ) +
  geom_line(linewidth = 1.4, color = "black") +
  geom_point(size = 2.5, color = "black") +
  geom_hline(
    yintercept = 40,
    linetype = "dashed",
    linewidth = 0.6,
    color = "grey40"
  ) +
  scale_y_continuous(
    limits = c(0, 100),
    breaks = seq(0, 100, 10),
    labels = function(x) paste0(x, "%")
  ) +
  labs(
    x = "Dose threshold",
    y = "Predicted Response Probability",
    title = "Prior Predictive Dose–Response Curve",
    subtitle = "Under the Skeptical Prior"
  ) +
  theme_minimal(base_size = 14) +
  theme(
    plot.title = element_text(face = "bold", hjust = 0.5),
    plot.subtitle = element_text(face = "bold", hjust = 0.5)
  )

Fit with ulam() Step 6: prepare the data list

dat_cat <- list(
  N = nrow(model_data_cat),
  y = model_data_cat$response,
  dose_2 = model_data_cat$dose_2,
  dose_3 = model_data_cat$dose_3,
  dose_4 = model_data_cat$dose_4,
  dose_5plus = model_data_cat$dose_5plus,
  age = model_data_cat$age_centered,
  imm = model_data_cat$immunosuppressed,
  loc_conj = model_data_cat$loc_conj,
  loc_other = model_data_cat$loc_other,
  loc_unknown = model_data_cat$loc_unknown,
  ecog = model_data_cat$ecog_23,
  stage_III = model_data_cat$stage_III,
  stage_IV = model_data_cat$stage_IV,
  stage_unstaged = model_data_cat$stage_unstaged,
  agent_q3 = model_data_cat$agent_pembro_q3,
  agent_q6 = model_data_cat$agent_pembro_q6,
  agent_mixed = model_data_cat$agent_pembro_mixed,
  agent_ipi = model_data_cat$agent_ipi_nivo,
  di = model_data_cat$di_pre_capped_centered,
  alpha_mu = qlogis(0.40)
)

Step 7A: fit the weakly informative categorical model

m_cat_weak <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_dose_2 * dose_2 +
      beta_dose_3 * dose_3 +
      beta_dose_4 * dose_4 +
      beta_dose_5plus * dose_5plus +
      beta_age * age +
      beta_imm * imm +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_ecog * ecog +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged +
      beta_q3 * agent_q3 +
      beta_q6 * agent_q6 +
      beta_mixed * agent_mixed +
      beta_ipi * agent_ipi +
      beta_di * di,

    alpha ~ normal(alpha_mu, 1),
    beta_dose_2 ~ normal(0.25, 0.25),
    beta_dose_3 ~ normal(0.15, 0.25),
    beta_dose_4 ~ normal(0.10, 0.25),
    beta_dose_5plus ~ normal(0.05, 0.25),

    beta_age ~ normal(0, 0.02),
    beta_imm ~ normal(-0.8, 0.2),
    beta_conj ~ normal(-1.0, 0.5),
    beta_other ~ normal(0, 0.3),
    beta_unknown ~ normal(0, 0.3),
    beta_ecog ~ normal(-0.3, 0.3),
    beta_stage_III ~ normal(0, 0.3),
    beta_stage_IV ~ normal(0, 0.3),
    beta_stage_unstaged ~ normal(0, 0.3),
    beta_q3 ~ normal(0, 0.3),
    beta_q6 ~ normal(0, 0.3),
    beta_mixed ~ normal(0, 0.3),
    beta_ipi ~ normal(0.4, 0.3),
    beta_di ~ normal(0.10, 0.12)
  ),
  data = dat_cat,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 1 finished in 1.4 seconds.
Chain 2 finished in 1.4 seconds.
Chain 3 finished in 1.4 seconds.
Chain 4 finished in 1.4 seconds.

All 4 chains finished successfully.
Mean chain execution time: 1.4 seconds.
Total execution time: 1.5 seconds.

Step 7B: fit the skeptical categorical model

m_cat_skeptical <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_dose_2 * dose_2 +
      beta_dose_3 * dose_3 +
      beta_dose_4 * dose_4 +
      beta_dose_5plus * dose_5plus +
      beta_age * age +
      beta_imm * imm +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_ecog * ecog +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged +
      beta_q3 * agent_q3 +
      beta_q6 * agent_q6 +
      beta_mixed * agent_mixed +
      beta_ipi * agent_ipi +
      beta_di * di,

    alpha ~ normal(alpha_mu, 1),
    beta_dose_2 ~ normal(0, 0.25),
    beta_dose_3 ~ normal(0, 0.25),
    beta_dose_4 ~ normal(0, 0.25),
    beta_dose_5plus ~ normal(0, 0.25),

    beta_age ~ normal(0, 0.02),
    beta_imm ~ normal(-0.8, 0.2),
    beta_conj ~ normal(-1.0, 0.5),
    beta_other ~ normal(0, 0.3),
    beta_unknown ~ normal(0, 0.3),
    beta_ecog ~ normal(-0.3, 0.3),
    beta_stage_III ~ normal(0, 0.3),
    beta_stage_IV ~ normal(0, 0.3),
    beta_stage_unstaged ~ normal(0, 0.3),
    beta_q3 ~ normal(0, 0.3),
    beta_q6 ~ normal(0, 0.3),
    beta_mixed ~ normal(0, 0.3),
    beta_ipi ~ normal(0.4, 0.3),
    beta_di ~ normal(0.10, 0.12)
  ),
  data = dat_cat,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 3 Rejecting initial value:

Chain 3   Log probability evaluates to log(0), i.e. negative infinity.

Chain 3   Stan can't start sampling from this initial value.

Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 finished in 1.4 seconds.
Chain 2 finished in 1.4 seconds.
Chain 3 finished in 1.4 seconds.
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 finished in 1.4 seconds.

All 4 chains finished successfully.
Mean chain execution time: 1.4 seconds.
Total execution time: 1.6 seconds.

Step 8: summarize posterior recovery

precis(m_cat_weak, depth = 2)

                            mean         sd        5.5%       94.5%      rhat
alpha               -0.444631788 0.32275175 -0.96313079  0.06274447 1.0008316
beta_dose_2          0.218593791 0.23161672 -0.14709093  0.59072613 0.9995034
beta_dose_3          0.262269682 0.21017056 -0.06625701  0.59951588 0.9999089
beta_dose_4          0.056630686 0.21181680 -0.27834247  0.38731997 1.0011369
beta_dose_5plus     -0.003974235 0.20801381 -0.33945555  0.33066333 1.0016734
beta_age            -0.014853496 0.01037943 -0.03158417  0.00161889 1.0002513
beta_imm            -0.811724462 0.18536265 -1.10780416 -0.51132139 1.0009065
beta_conj           -0.399761025 0.37148437 -1.00030502  0.18967661 1.0035964
beta_other           0.200677741 0.26462877 -0.22429375  0.62613622 1.0018965
beta_unknown        -0.054670150 0.28969365 -0.52139417  0.41734258 1.0000970
beta_ecog           -0.279992499 0.21359540 -0.61990250  0.05969565 1.0013846
beta_stage_III      -0.166596570 0.22843472 -0.53630961  0.19626046 1.0007774
beta_stage_IV       -0.052973139 0.22992282 -0.42106358  0.31939720 1.0003810
beta_stage_unstaged -0.063201689 0.25828790 -0.47098546  0.35273491 1.0000166
beta_q3             -0.241749870 0.23841759 -0.62676493  0.13894551 1.0002331
beta_q6              0.158146846 0.26025881 -0.26730403  0.57410726 1.0022981
beta_mixed           0.030760277 0.27776433 -0.40882390  0.46939998 1.0016181
beta_ipi             0.537865836 0.26111269  0.12650435  0.95953993 1.0009745
beta_di              0.109799173 0.12042578 -0.08353605  0.30134632 1.0024567
                    ess_bulk
alpha               4070.058
beta_dose_2         5841.800
beta_dose_3         6943.336
beta_dose_4         6284.661
beta_dose_5plus     6286.150
beta_age            8389.672
beta_imm            7640.908
beta_conj           7835.910
beta_other          9316.932
beta_unknown        8228.052
beta_ecog           7432.536
beta_stage_III      5767.613
beta_stage_IV       6289.417
beta_stage_unstaged 7001.337
beta_q3             8474.597
beta_q6             7370.943
beta_mixed          8044.993
beta_ipi            8021.283
beta_di             7911.342

precis(m_cat_skeptical, depth = 2)

                             mean         sd        5.5%        94.5%      rhat
alpha               -2.144534e-01 0.32909744 -0.74518865  0.314384045 1.0005208
beta_dose_2          1.100115e-02 0.22467968 -0.33643462  0.370394240 1.0005534
beta_dose_3          1.912787e-01 0.20219857 -0.12826961  0.518600431 1.0004099
beta_dose_4          2.772701e-02 0.20812921 -0.30286562  0.362792378 1.0009220
beta_dose_5plus      4.961877e-05 0.21609181 -0.34379926  0.351254397 1.0006136
beta_age            -1.453522e-02 0.01012426 -0.03097165  0.001745046 1.0021447
beta_imm            -8.087722e-01 0.18249081 -1.10398119 -0.518836155 1.0008839
beta_conj           -4.041414e-01 0.36769214 -0.98947320  0.182738342 1.0020495
beta_other           1.923839e-01 0.26500978 -0.23827399  0.613618742 1.0001355
beta_unknown        -5.173300e-02 0.28451811 -0.50380071  0.396934305 0.9998247
beta_ecog           -2.680675e-01 0.22278110 -0.62438235  0.097888108 0.9996854
beta_stage_III      -1.597883e-01 0.22554320 -0.51692877  0.195407311 1.0008534
beta_stage_IV       -4.668026e-02 0.23626825 -0.42721462  0.339691552 1.0015622
beta_stage_unstaged -6.245959e-02 0.26112474 -0.48090980  0.355046090 1.0020460
beta_q3             -2.361138e-01 0.23374196 -0.60295669  0.139467900 1.0001683
beta_q6              1.573837e-01 0.25038421 -0.23985896  0.562352429 1.0006843
beta_mixed           3.029047e-02 0.27033689 -0.39876400  0.453363676 1.0002738
beta_ipi             5.381944e-01 0.26823325  0.11720772  0.972023577 1.0002778
beta_di              1.056564e-01 0.12154617 -0.09251232  0.302439130 1.0001992
                    ess_bulk
alpha               3310.173
beta_dose_2         4443.736
beta_dose_3         5688.733
beta_dose_4         4986.470
beta_dose_5plus     6023.444
beta_age            7399.270
beta_imm            6941.475
beta_conj           7422.270
beta_other          5761.959
beta_unknown        6935.168
beta_ecog           6149.302
beta_stage_III      4267.822
beta_stage_IV       4887.359
beta_stage_unstaged 7199.590
beta_q3             6885.955
beta_q6             6739.097
beta_mixed          6159.123
beta_ipi            6659.706
beta_di             8169.132

Step 9: posterior predictive checks

Weak prior

post_cat_weak <- extract.samples(m_cat_weak)

pp_rates_cat_weak <- sapply(seq_along(post_cat_weak$alpha), function(i) {
  p <- plogis(
    post_cat_weak$alpha[i] +
      post_cat_weak$beta_dose_2[i] * dat_cat$dose_2 +
      post_cat_weak$beta_dose_3[i] * dat_cat$dose_3 +
      post_cat_weak$beta_dose_4[i] * dat_cat$dose_4 +
      post_cat_weak$beta_dose_5plus[i] * dat_cat$dose_5plus +
      post_cat_weak$beta_age[i] * dat_cat$age +
      post_cat_weak$beta_imm[i] * dat_cat$imm +
      post_cat_weak$beta_conj[i] * dat_cat$loc_conj +
      post_cat_weak$beta_other[i] * dat_cat$loc_other +
      post_cat_weak$beta_unknown[i] * dat_cat$loc_unknown +
      post_cat_weak$beta_ecog[i] * dat_cat$ecog +
      post_cat_weak$beta_stage_III[i] * dat_cat$stage_III +
      post_cat_weak$beta_stage_IV[i] * dat_cat$stage_IV +
      post_cat_weak$beta_stage_unstaged[i] * dat_cat$stage_unstaged +
      post_cat_weak$beta_q3[i] * dat_cat$agent_q3 +
      post_cat_weak$beta_q6[i] * dat_cat$agent_q6 +
      post_cat_weak$beta_mixed[i] * dat_cat$agent_mixed +
      post_cat_weak$beta_ipi[i] * dat_cat$agent_ipi +
      post_cat_weak$beta_di[i] * dat_cat$di
  )
  y_rep <- rbinom(dat_cat$N, size = 1, prob = p)
  mean(y_rep)
})

pp_df_cat_weak <- tibble(simulated_response_rate = pp_rates_cat_weak)
observed_rate_cat <- mean(model_data_cat$response)

ggplot(pp_df_cat_weak, aes(x = simulated_response_rate)) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7, color = "white") +
  geom_vline(
    xintercept = observed_rate_cat,
    color = "red",
    linewidth = 1.2,
    linetype = "dashed"
  ) +
  scale_x_continuous(limits = c(0, 1)) +
  labs(
    title = "Posterior Predictive Check: Categorical Model",
    subtitle = "Weakly informative prior; red dashed line = observed response rate",
    x = "Simulated response rate",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold")
  )

Warning: Removed 2 rows containing missing values or values outside the scale range
(`geom_bar()`).

26 Model Based Validation

dat_log <- list(
  N = nrow(model_data),
  y = model_data$response,
  log_dose = model_data$log_dose,
  age = model_data$age_centered,
  imm = model_data$immunosuppressed,
  loc_conj = model_data$loc_conj,
  loc_other = model_data$loc_other,
  loc_unknown = model_data$loc_unknown,
  ecog = model_data$ecog_23,
  stage_III = model_data$stage_III,
  stage_IV = model_data$stage_IV,
  stage_unstaged = model_data$stage_unstaged,
  agent_q3 = model_data$agent_pembro_q3,
  agent_q6 = model_data$agent_pembro_q6,
  agent_mixed = model_data$agent_pembro_mixed,
  agent_ipi = model_data$agent_ipi_nivo,
  di = model_data$di_pre_capped_centered,
  alpha_mu = qlogis(0.40)
)

m_log_weak <- ulam(
  alist(
    y ~ bernoulli(p),
    logit(p) <- alpha +
      beta_log_dose * log_dose +
      beta_age * age +
      beta_imm * imm +
      beta_conj * loc_conj +
      beta_other * loc_other +
      beta_unknown * loc_unknown +
      beta_ecog * ecog +
      beta_stage_III * stage_III +
      beta_stage_IV * stage_IV +
      beta_stage_unstaged * stage_unstaged +
      beta_q3 * agent_q3 +
      beta_q6 * agent_q6 +
      beta_mixed * agent_mixed +
      beta_ipi * agent_ipi +
      beta_di * di,

    alpha ~ normal(alpha_mu, 1),
    beta_log_dose ~ normal(0.30, 0.20),

    beta_age ~ normal(0, 0.02),
    beta_imm ~ normal(-0.8, 0.2),
    beta_conj ~ normal(-0.6, 0.5),
    beta_other ~ normal(0, 0.3),
    beta_unknown ~ normal(0, 0.3),
    beta_ecog ~ normal(-0.3, 0.3),
    beta_stage_III ~ normal(0, 0.3),
    beta_stage_IV ~ normal(0, 0.3),
    beta_stage_unstaged ~ normal(0, 0.3),
    beta_q3 ~ normal(0, 0.3),
    beta_q6 ~ normal(0, 0.3),
    beta_mixed ~ normal(0, 0.3),
    beta_ipi ~ normal(0.4, 0.3),
    beta_di ~ normal(0.10, 0.12)
  ),
  data = dat_log,
  chains = 4,
  cores = 4,
  iter = 2000
)

Running MCMC with 4 parallel chains, with 1 thread(s) per chain...

Chain 1 Iteration:    1 / 2000 [  0%]  (Warmup) 

Chain 2 Rejecting initial value:

Chain 2   Log probability evaluates to log(0), i.e. negative infinity.

Chain 2   Stan can't start sampling from this initial value.

Chain 2 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 3 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 4 Iteration:    1 / 2000 [  0%]  (Warmup) 
Chain 1 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 3 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 1 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 1 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 2 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 2 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 2 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 3 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  100 / 2000 [  5%]  (Warmup) 
Chain 4 Iteration:  200 / 2000 [ 10%]  (Warmup) 
Chain 1 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 1 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 1 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 2 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 2 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 2 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 3 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  300 / 2000 [ 15%]  (Warmup) 
Chain 4 Iteration:  400 / 2000 [ 20%]  (Warmup) 
Chain 1 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 1 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 2 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 2 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 3 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 3 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  500 / 2000 [ 25%]  (Warmup) 
Chain 4 Iteration:  600 / 2000 [ 30%]  (Warmup) 
Chain 4 Iteration:  700 / 2000 [ 35%]  (Warmup) 
Chain 1 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 1 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 1 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 1 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 2 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 2 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 2 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 2 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 3 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 3 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration:  800 / 2000 [ 40%]  (Warmup) 
Chain 4 Iteration:  900 / 2000 [ 45%]  (Warmup) 
Chain 1 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 1 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 2 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 2 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 3 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 3 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1000 / 2000 [ 50%]  (Warmup) 
Chain 4 Iteration: 1001 / 2000 [ 50%]  (Sampling) 
Chain 4 Iteration: 1100 / 2000 [ 55%]  (Sampling) 
Chain 4 Iteration: 1200 / 2000 [ 60%]  (Sampling) 
Chain 1 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 1 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 1 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 2 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 2 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 2 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 3 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1300 / 2000 [ 65%]  (Sampling) 
Chain 4 Iteration: 1400 / 2000 [ 70%]  (Sampling) 
Chain 1 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 2 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 3 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 3 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1500 / 2000 [ 75%]  (Sampling) 
Chain 4 Iteration: 1600 / 2000 [ 80%]  (Sampling) 
Chain 4 Iteration: 1700 / 2000 [ 85%]  (Sampling) 
Chain 1 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 2 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 3 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 3 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 Iteration: 1800 / 2000 [ 90%]  (Sampling) 
Chain 4 Iteration: 1900 / 2000 [ 95%]  (Sampling) 
Chain 1 finished in 1.1 seconds.
Chain 2 finished in 1.1 seconds.
Chain 3 finished in 1.2 seconds.
Chain 4 Iteration: 2000 / 2000 [100%]  (Sampling) 
Chain 4 finished in 1.2 seconds.

All 4 chains finished successfully.
Mean chain execution time: 1.2 seconds.
Total execution time: 1.4 seconds.

precis(m_log_weak, depth = 2)

                           mean         sd        5.5%        94.5%      rhat
alpha               -0.58826376 0.29732755 -1.07025016 -0.108509127 0.9999341
beta_log_dose        0.18766733 0.14433517 -0.04017528  0.423314664 0.9993518
beta_age            -0.01360420 0.01064732 -0.03093337  0.003369368 1.0004841
beta_imm            -0.78206658 0.19241235 -1.09791059 -0.478361775 1.0024652
beta_conj           -0.68262917 0.38426643 -1.28610180 -0.072205662 1.0008090
beta_other          -0.01586078 0.26862281 -0.44419465  0.412067183 1.0033651
beta_unknown         0.03727677 0.28702391 -0.42386188  0.492913877 1.0025029
beta_ecog           -0.10549886 0.22062201 -0.44754548  0.242897714 1.0001581
beta_stage_III      -0.12335088 0.23011502 -0.49244644  0.238492445 1.0005204
beta_stage_IV        0.15848031 0.22184986 -0.19201231  0.518724001 1.0005029
beta_stage_unstaged  0.06302878 0.26657241 -0.36496144  0.484142752 1.0008122
beta_q3              0.11666515 0.24034903 -0.27707964  0.502414317 1.0022966
beta_q6             -0.05514219 0.25652521 -0.46265847  0.350442051 1.0012700
beta_mixed           0.05988032 0.27849797 -0.38613659  0.498705596 1.0016702
beta_ipi             0.41440242 0.26743624 -0.00836182  0.842596943 1.0013758
beta_di              0.11485836 0.12183508 -0.08005045  0.309963849 1.0018074
                     ess_bulk
alpha                4141.409
beta_log_dose        5634.861
beta_age             9687.920
beta_imm             9822.915
beta_conj            6928.335
beta_other           9424.350
beta_unknown         9031.692
beta_ecog            7444.866
beta_stage_III       4892.833
beta_stage_IV        5678.428
beta_stage_unstaged  7834.412
beta_q3              7908.712
beta_q6              8122.001
beta_mixed           8587.513
beta_ipi            10699.942
beta_di              8625.797

27 Log-dose posterior predicted curves

doses <- 1:15

new_data_log_validation <- data.frame(
  log_dose = log(doses),
  age = 0,
  imm = 0,
  loc_conj = 0,
  loc_other = 0,
  loc_unknown = 0,
  ecog = 0,
  stage_III = 0,
  stage_IV = 0,
  stage_unstaged = 0,
  agent_q3 = 0,
  agent_q6 = 0,
  agent_mixed = 0,
  agent_ipi = 0,
  di = 0
)

p_log_null <- link(m_log_weak, data = new_data_log_validation)

plot_df_log_null <- tibble(
  dose_number = doses,
  mean_p = apply(p_log_null, 2, mean),
  lower = apply(p_log_null, 2, PI, 0.89)[1, ],
  upper = apply(p_log_null, 2, PI, 0.89)[2, ],
  scenario = "Known positive effect (true β = 0.30)"
)

# Positive-effect simulation
p_log_pos <- link(m_log_weak, data = new_data_log_validation)

plot_df_log_pos <- tibble(
  dose_number = doses,
  mean_p = apply(p_log_pos, 2, mean),
  lower = apply(p_log_pos, 2, PI, 0.89)[1, ],
  upper = apply(p_log_pos, 2, PI, 0.89)[2, ],
  scenario = "Positive effect (true β = 0.20)"
)

plot_df_log_validation <- bind_rows(
  plot_df_log_null,
  plot_df_log_pos
)

ggplot(
  plot_df_log_validation,
  aes(x = dose_number, y = mean_p)
) +
  geom_ribbon(
    aes(ymin = lower, ymax = upper),
    fill = "steelblue",
    alpha = 0.18
  ) +
  geom_line(
    linewidth = 1.2,
    color = "steelblue4"
  ) +
  geom_point(
    size = 2.2,
    shape = 21,
    stroke = 0.8,
    fill = "white",
    color = "steelblue4"
  ) +
  facet_wrap(~ scenario, ncol = 2) +
  scale_y_continuous(
    limits = c(0, 1),
    breaks = seq(0, 1, by = 0.1),
    labels = scales::percent_format(accuracy = 1)
  ) +
  scale_x_continuous(
    breaks = 1:15
  ) +
  labs(
    title = "Posterior predicted response probability by dose",
    subtitle = "Log-dose model fit to simulated data under null and known positive-effect scenarios",
    x = "Number of doses",
    y = "Predicted response probability"
  ) +
  theme_minimal(base_size = 13) +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    strip.text = element_text(face = "bold"),
    panel.grid.minor = element_blank()
  )

library(tidyverse)
library(patchwork)

Warning: package 'patchwork' was built under R version 4.4.1

fmt_pct_cap <- function(x, digits = 1, cap = 99.9) {
  pct <- 100 * x
  if (pct >= cap) {
    paste0(">", cap, "%")
  } else {
    paste0(round(pct, digits), "%")
  }
}

make_linear_validation_plot <- function(
  posterior,
  true_beta,
  title,
  subtitle,
  x_label = expression(beta[dose]),
  threshold_1 = 0.00,
  threshold_2 = 0.05,
  threshold_3 = 0.10,
  annotation_x = 0.10
) {

  dens <- density(posterior)
  dens_df <- tibble(x = dens$x, y = dens$y)

  ci_lower <- quantile(posterior, 0.055)
  ci_upper <- quantile(posterior, 0.945)
  ymax <- max(dens_df$y)

  ggplot() +
    geom_line(
      data = dens_df,
      aes(x = x, y = y),
      linewidth = 1,
      color = "steelblue"
    ) +
    geom_area(
      data = subset(dens_df, x > threshold_1 & x < threshold_2),
      aes(x = x, y = y),
      fill = "darkgreen",
      alpha = 0.30
    ) +
    geom_area(
      data = subset(dens_df, x >= threshold_2 & x < threshold_3),
      aes(x = x, y = y),
      fill = "#2E7C71",
      alpha = 0.30
    ) +
    geom_area(
      data = subset(dens_df, x >= threshold_3),
      aes(x = x, y = y),
      fill = "purple",
      alpha = 0.30
    ) +
    geom_vline(
      xintercept = true_beta,
      linetype = "dashed",
      color = "red",
      linewidth = 1
    ) +
    geom_vline(
      xintercept = c(ci_lower, ci_upper),
      linetype = "dotted",
      color = "darkblue"
    ) +
    annotate(
      "text",
      x = true_beta,
      y = ymax * 0.95,
      label = paste0("True β = ", round(true_beta, 2)),
      hjust = ifelse(true_beta == 0, -0.2, -0.1),
      color = "red",
      size = 3.5
    ) +
    annotate(
      "text",
      x = mean(posterior),
      y = ymax * 0.58,
      label = paste0(
        "89% CrI: [",
        round(ci_lower, 2), ", ",
        round(ci_upper, 2), "]"
      ),
      size = 3.4
    ) +
    annotate(
      "text",
      x = annotation_x,
      y = ymax * 0.85,
      label = paste0("P(β > 0) = ", fmt_pct_cap(mean(posterior > 0))),
      hjust = 0,
      size = 3.4,
      color = "darkgreen"
    ) +
    annotate(
      "text",
      x = annotation_x,
      y = ymax * 0.75,
      label = paste0("P(β > 0.05) = ", fmt_pct_cap(mean(posterior > 0.05))),
      hjust = 0,
      size = 3.4,
      color = "#2E7C71"
    ) +
    annotate(
      "text",
      x = annotation_x,
      y = ymax * 0.65,
      label = paste0("P(β > 0.10) = ", fmt_pct_cap(mean(posterior > 0.10))),
      hjust = 0,
      size = 3.4,
      color = "purple"
    ) +
    labs(
      title = title,
      subtitle = subtitle,
      x = x_label,
      y = "Posterior Density"
    ) +
    theme_minimal() +
    theme(
      plot.title = element_text(hjust = 0.5, face = "bold"),
      plot.subtitle = element_text(hjust = 0.5, face = "bold")
    )
}

make_log_validation_plot <- function(
  posterior,
  true_beta,
  title,
  subtitle,
  annotation_x = 0.50
) {

  dens <- density(posterior)
  dens_df <- tibble(x = dens$x, y = dens$y)

  ci_lower <- quantile(posterior, 0.055)
  ci_upper <- quantile(posterior, 0.945)
  ymax <- max(dens_df$y)

  ggplot() +
    geom_line(
      data = dens_df,
      aes(x = x, y = y),
      linewidth = 1,
      color = "steelblue"
    ) +
    geom_area(
      data = subset(dens_df, x > 0 & x < 0.10),
      aes(x = x, y = y),
      fill = "darkgreen",
      alpha = 0.30
    ) +
    geom_area(
      data = subset(dens_df, x >= 0.10 & x < 0.20),
      aes(x = x, y = y),
      fill = "#2E7C71",
      alpha = 0.30
    ) +
    geom_area(
      data = subset(dens_df, x >= 0.20),
      aes(x = x, y = y),
      fill = "purple",
      alpha = 0.30
    ) +
    geom_vline(
      xintercept = true_beta,
      linetype = "dashed",
      color = "red",
      linewidth = 1
    ) +
    geom_vline(
      xintercept = c(ci_lower, ci_upper),
      linetype = "dotted",
      color = "darkblue"
    ) +
    annotate(
      "text",
      x = true_beta,
      y = ymax * 0.95,
      label = paste0("True β = ", round(true_beta, 2)),
      hjust = -0.1,
      color = "red",
      size = 3.5
    ) +
    annotate(
      "text",
      x = mean(posterior),
      y = ymax * 0.58,
      label = paste0(
        "89% CrI: [",
        round(ci_lower, 2), ", ",
        round(ci_upper, 2), "]"
      ),
      size = 3.4
    ) +
    annotate(
      "text",
      x = annotation_x,
      y = ymax * 0.85,
      label = paste0("P(β > 0) = ", fmt_pct_cap(mean(posterior > 0))),
      hjust = 0,
      size = 3.4,
      color = "darkgreen"
    ) +
    annotate(
      "text",
      x = annotation_x,
      y = ymax * 0.75,
      label = paste0("P(β > 0.10) = ", fmt_pct_cap(mean(posterior > 0.10))),
      hjust = 0,
      size = 3.4,
      color = "#2E7C71"
    ) +
    annotate(
      "text",
      x = annotation_x,
      y = ymax * 0.65,
      label = paste0("P(β > 0.20) = ", fmt_pct_cap(mean(posterior > 0.20))),
      hjust = 0,
      size = 3.4,
      color = "purple"
    ) +
    labs(
      title = title,
      subtitle = subtitle,
      x = expression(beta[log(dose)]),
      y = "Posterior Density"
    ) +
    theme_minimal() +
    theme(
      plot.title = element_text(hjust = 0.5, face = "bold"),
      plot.subtitle = element_text(hjust = 0.5, face = "bold")
    )
}

posterior_null_linear <- extract.samples(m_ecog_weak)$beta_dose
posterior_moderate_linear <- extract.samples(m_ecog_weak_pos)$beta_dose
posterior_log_dose <- extract.samples(m_log_weak)$beta_log_dose

plot_null_linear_validation <- make_linear_validation_plot(
  posterior = posterior_null_linear,
  true_beta = 0,
  title = "Null Linear Effect Validation",
  subtitle = "True β = 0",
  annotation_x = 0.10
)

plot_moderate_linear_validation <- make_linear_validation_plot(
  posterior = posterior_moderate_linear,
  true_beta = 0.20,
  title = "Moderate Linear Effect Validation",
  subtitle = "True β = 0.20",
  annotation_x = 0.25
)

plot_sigmoid_log_validation <- make_log_validation_plot(
  posterior = posterior_log_dose,
  true_beta = 0.30,
  title = "Log-Dose Validation",
  subtitle = "True β = 0.30",
  annotation_x = 0.50
)

posterior_cat_combined <-
  bind_rows(
    tibble(beta = extract.samples(m_cat_weak)$beta_dose_2, threshold = "Dose 2 vs 1", true_beta = 0.25),
    tibble(beta = extract.samples(m_cat_weak)$beta_dose_3, threshold = "Dose 3 vs 2", true_beta = 0.15),
    tibble(beta = extract.samples(m_cat_weak)$beta_dose_4, threshold = "Dose 4 vs 3", true_beta = 0.10),
    tibble(beta = extract.samples(m_cat_weak)$beta_dose_5plus, threshold = "Dose ≥5 vs 4", true_beta = 0.05)
  ) |>
  mutate(
    threshold = factor(
      threshold,
      levels = c("Dose 2 vs 1", "Dose 3 vs 2", "Dose 4 vs 3", "Dose ≥5 vs 4")
    )
  )

cols_cat <- c(
  "Dose 2 vs 1"  = "#1F78B4",
  "Dose 3 vs 2"  = "#1B9E77",
  "Dose 4 vs 3"  = "#D95F02",
  "Dose ≥5 vs 4" = "#7B2CBF"
)

summ_cat <-
  posterior_cat_combined |>
  group_by(threshold) |>
  summarise(
    p_gt0 = mean(beta > 0),
    OR_md = exp(median(beta)),
    true_beta = first(true_beta),
    .groups = "drop"
  )

ann_text <- paste0(
  "Posterior P(β > 0):\n",
  "Dose 2 vs 1:  ", fmt_pct_cap(summ_cat$p_gt0[summ_cat$threshold == "Dose 2 vs 1"]), "\n",
  "Dose 3 vs 2:  ", fmt_pct_cap(summ_cat$p_gt0[summ_cat$threshold == "Dose 3 vs 2"]), "\n",
  "Dose 4 vs 3:  ", fmt_pct_cap(summ_cat$p_gt0[summ_cat$threshold == "Dose 4 vs 3"]), "\n",
  "Dose ≥5 vs 4: ", fmt_pct_cap(summ_cat$p_gt0[summ_cat$threshold == "Dose ≥5 vs 4"]), "\n\n",
  "Median OR:\n",
  "Dose 2 vs 1:  ×", sprintf("%.2f", summ_cat$OR_md[summ_cat$threshold == "Dose 2 vs 1"]), "\n",
  "Dose 3 vs 2:  ×", sprintf("%.2f", summ_cat$OR_md[summ_cat$threshold == "Dose 3 vs 2"]), "\n",
  "Dose 4 vs 3:  ×", sprintf("%.2f", summ_cat$OR_md[summ_cat$threshold == "Dose 4 vs 3"]), "\n",
  "Dose ≥5 vs 4: ×", sprintf("%.2f", summ_cat$OR_md[summ_cat$threshold == "Dose ≥5 vs 4"])
)

dens_list <- posterior_cat_combined |>
  group_by(threshold) |>
  summarise(dens = list(density(beta, adjust = 1.1)), .groups = "drop")

ymax_cat <- max(vapply(dens_list$dens, function(d) max(d$y), numeric(1)))

plot_categorical_validation <-
  ggplot(posterior_cat_combined, aes(x = beta)) +
  geom_density(aes(fill = threshold), alpha = 0.18, color = NA, adjust = 1.1) +
  geom_density(aes(color = threshold), fill = NA, linewidth = 1.15, adjust = 1.1) +
  geom_vline(
    data = summ_cat,
    aes(xintercept = true_beta, color = threshold),
    linetype = "dashed",
    linewidth = 0.8
  ) +
  scale_fill_manual(values = cols_cat) +
  scale_color_manual(values = cols_cat) +
  annotate(
    "label",
    x = 0.75,
    y = ymax_cat,
    label = ann_text,
    hjust = 0,
    vjust = 1,
    size = 3.1,
    label.size = 0.25,
    fill = "white",
    alpha = 0.92
  ) +
  labs(
    title = "Categorical Threshold Validation",
    subtitle = "Dashed lines show true simulated values",
    x = "β (log-odds; incremental effect)",
    y = "Density",
    color = "Threshold",
    fill = "Threshold"
  ) +
  coord_cartesian(xlim = c(-0.5, 1.0), clip = "off") +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, face = "bold"),
    legend.position = "bottom",
    plot.margin = margin(t = 10, r = 40, b = 10, l = 10)
  )

combined_validation <-
  (plot_null_linear_validation | plot_moderate_linear_validation) /
  (plot_sigmoid_log_validation | plot_categorical_validation) +
  plot_annotation(
    tag_levels = "A",
    theme = theme(
      plot.tag = element_text(face = "bold", size = 14)
    )
  )

combined_validation

Figure 1: Model validation via simulation-based calibration for objective response rate. Posterior distributions from Bayesian response models fitted to simulated datasets with known dose-effect structures. (A) Null linear scenario: true β = 0; the model remains centered near the null while appropriately preserving uncertainty. (B) Moderate linear effect: true β = 0.20; the model recovers a clinically meaningful positive dose-response signal. (C) Log-dose scenario: true β = 0.30 on the log-dose scale; the model recovers a diminishing-returns pattern consistent with stronger early gains at lower cumulative exposure. (D) Categorical threshold model: true incremental effects β2 = 0.25, β3 = 0.15, β4 = 0.10, and β5+ = 0.05 (dashed lines); the model recovers heterogeneous threshold effects without imposing a single functional form. Together, these panels show that the modeling framework can distinguish null, linear, nonlinear, and thresholded dose-response structures while quantifying posterior uncertainty.

save_files(
  save_object = combined_validation,
  filename = "Model Validation Four Panel Figure ORR",
  subD = "files/Simulated Data/Validation Figures"
)

File saved to: /Users/davidmiller/Partners HealthCare Dropbox/David Miller/mLab/Projects/FIRST and Neoadjuvant Outcomes in CSCC at MGH-MEEI/files/Simulated Data/Validation Figures/Model Validation Four Panel Figure ORR-2026-03-19-13-29-26.rds 

save_files(
  save_object = combined_validation,
  filename = "Model Validation Four Panel Figure ORR",
  subD = "files/Simulated Data/Validation Figures",
  extension = ".png",
  width = 11,
  height = 9,
  dpi = 300,
  units = "in"
)

File saved to: /Users/davidmiller/Partners HealthCare Dropbox/David Miller/mLab/Projects/FIRST and Neoadjuvant Outcomes in CSCC at MGH-MEEI/files/Simulated Data/Validation Figures/Model Validation Four Panel Figure ORR-2026-03-19-13-29-26.png 

save(
  m_ecog_weak,
  m_ecog_weak_pos,
  m_log_weak,
  m_cat_weak,
  file = here::here("files/Simulated Data/validation_models_ORR.RData")
)