Bayesian Logistic Regression with rstanarm

Setup

Load packages

library(tidyverse)
library(caret)
library(GGally)
library(ggplot2)
library(corrplot)
library(bayesplot)
theme_set(bayesplot::theme_default(base_family = "sans"))
library(rstanarm)
options(mc.cores = 1)
library(loo)
library(projpred)
SEED=14124869

1 Introduction

The introduction to Bayesian logistic regression and rstanarm is from a CRAN vignette by Jonah Gabry and Ben Goodrich. CRAN vignette was modified to this notebook by Aki Vehtari. Instead of wells data in CRAN vignette, Pima Indians data is used. The end of this notebook differs significantly from the CRAN vignette. You can read more about how to use rstanarm in several vignettes at CRAN. This vignette includes also demonstrations of calibration plots and projection predictive variable selection.

Acknowledgements: Preprocessing of Pima Indian dataset is from a noteebok by Lao Zhang

---

2 Bayesian analysis

This vignette explains how to estimate generalized linear models (GLMs) for binary (Bernoulli) and Binomial response variables using the stan_glm function in the rstanarm package.

The four steps of a Bayesian analysis are

1. Specify a joint distribution for the outcome(s) and all the unknowns, which typically takes the form of a marginal prior distribution for the unknowns multiplied by a likelihood for the outcome(s) conditional on the unknowns. This joint distribution is proportional to a posterior distribution of the unknowns conditional on the observed data
2. Draw from posterior distribution using Markov Chain Monte Carlo (MCMC).
3. Evaluate how well the model fits the data and possibly revise the model.
4. Draw from the posterior predictive distribution of the outcome(s) given interesting values of the predictors in order to visualize how a manipulation of a predictor affects (a function of) the outcome(s).

Steps 3 and 4 are covered in more depth by the vignette entitled “How to Use the rstanarm Package”. This vignette focuses on Step 1 when the likelihood is the product of conditionally independent binomial distributions (possibly with only one trial per observation).

2.1 Likelihood

For a binomial GLM the likelihood for one observation \(y\) can be written as a conditionally binomial PMF \[\binom{n}{y} \pi^{y} (1 - \pi)^{n - y},\] where \(n\) is the known number of trials, \(\pi = g^{-1}(\eta)\) is the probability of success and \(\eta = \alpha + \mathbf{x}^\top \boldsymbol{\beta}\) is a linear predictor. For a sample of size \(N\), the likelihood of the entire sample is the product of \(N\) individual likelihood contributions.

Because \(\pi\) is a probability, for a binomial model the link function \(g\) maps between the unit interval (the support of \(\pi\)) and the set of all real numbers \(\mathbb{R}\). When applied to a linear predictor \(\eta\) with values in \(\mathbb{R}\), the inverse link function \(g^{-1}(\eta)\) therefore returns a valid probability between 0 and 1.

The two most common link functions used for binomial GLMs are the logit and probit functions. With the logit (or log-odds) link function \(g(x) = \ln{\left(\frac{x}{1-x}\right)}\), the likelihood for a single observation becomes

\[\binom{n}{y}\left(\text{logit}^{-1}(\eta)\right)^y \left(1 - \text{logit}^{-1}(\eta)\right)^{n-y} = \binom{n}{y} \left(\frac{e^{\eta}}{1 + e^{\eta}}\right)^{y} \left(\frac{1}{1 + e^{\eta}}\right)^{n - y}\]

and the probit link function \(g(x) = \Phi^{-1}(x)\) yields the likelihood

\[\binom{n}{y} \left(\Phi(\eta)\right)^{y} \left(1 - \Phi(\eta)\right)^{n - y},\]

where \(\Phi\) is the CDF of the standard normal distribution. The differences between the logit and probit functions are minor and – if, as rstanarm does by default, the probit is scaled so its slope at the origin matches the logit’s – the two link functions should yield similar results. With stan_glm, binomial models with a logit link function can typically be fit slightly faster than the identical model with a probit link because of how the two models are implemented in Stan. Unless the user has a specific reason to prefer the probit link, we recommend the logit simply because it will be slightly faster and more numerically stable.

In theory, there are infinitely many possible link functions, although in practice only a few are typically used. Other common choices are the cauchit and cloglog functions, which can also be used with stan_glm (every link function compatible withglm will work with stan_glm).

A full Bayesian analysis requires specifying prior distributions \(f(\alpha)\) and \(f(\boldsymbol{\beta})\) for the intercept and vector of regression coefficients. When using stan_glm, these distributions can be set using the prior_intercept and prior arguments. The stan_glm function supports a variety of prior distributions, which are explained in the rstanarm documentation (help(priors, package = 'rstanarm')).

As an example, suppose we have \(K\) predictors and believe — prior to seeing the data — that \(\alpha, \beta_1, \dots, \beta_K\) are as likely to be positive as they are to be negative, but are highly unlikely to be far from zero. These beliefs can be represented by normal distributions with mean zero and a small scale (standard deviation). To give \(\alpha\) and each of the \(\beta\)s this prior (with a scale of 1, say), in the call to stan_glm we would include the arguments prior_intercept = normal(0,1) and prior = normal(0,1).

If, on the other hand, we have less a priori confidence that the parameters will be close to zero then we could use a larger scale for the normal distribution and/or a distribution with heavier tails than the normal like the Student t distribution. Step 1 in the “How to Use the rstanarm Package” vignette discusses one such example.

2.2 Posterior

With independent prior distributions, the joint posterior distribution for \(\alpha\) and \(\boldsymbol{\beta}\) is proportional to the product of the priors and the \(N\) likelihood contributions:

\[f\left(\alpha,\boldsymbol{\beta} | \mathbf{y},\mathbf{X}\right) \propto f\left(\alpha\right) \times \prod_{k=1}^K f\left(\beta_k\right) \times \prod_{i=1}^N { g^{-1}\left(\eta_i\right)^{y_i} \left(1 - g^{-1}\left(\eta_i\right)\right)^{n_i-y_i}}.\]

This is posterior distribution that stan_glm will draw from when using MCMC.

2.3 Logistic Regression

When the logit link function is used the model is often referred to as a logistic regression model (the inverse logit function is the CDF of the standard logistic distribution). As an example, here we will show how to carry out a analysis for Pima Indians data set similar to analysis from Chapter 5.4 of Gelman and Hill (2007) using stan_glm.

3 Diabetes data

# file preview shows a header row
diabetes <- read.csv("diabetes.csv", header = TRUE)

# first look at the data set using summary() and str() to understand what type of data are you working
# with
summary(diabetes)

  Pregnancies        Glucose      BloodPressure    SkinThickness      Insulin     
 Min.   : 0.000   Min.   :  0.0   Min.   :  0.00   Min.   : 0.00   Min.   :  0.0  
 1st Qu.: 1.000   1st Qu.: 99.0   1st Qu.: 62.00   1st Qu.: 0.00   1st Qu.:  0.0  
 Median : 3.000   Median :117.0   Median : 72.00   Median :23.00   Median : 30.5  
 Mean   : 3.845   Mean   :120.9   Mean   : 69.11   Mean   :20.54   Mean   : 79.8  
 3rd Qu.: 6.000   3rd Qu.:140.2   3rd Qu.: 80.00   3rd Qu.:32.00   3rd Qu.:127.2  
 Max.   :17.000   Max.   :199.0   Max.   :122.00   Max.   :99.00   Max.   :846.0  
      BMI        DiabetesPedigreeFunction      Age           Outcome     
 Min.   : 0.00   Min.   :0.0780           Min.   :21.00   Min.   :0.000  
 1st Qu.:27.30   1st Qu.:0.2437           1st Qu.:24.00   1st Qu.:0.000  
 Median :32.00   Median :0.3725           Median :29.00   Median :0.000  
 Mean   :31.99   Mean   :0.4719           Mean   :33.24   Mean   :0.349  
 3rd Qu.:36.60   3rd Qu.:0.6262           3rd Qu.:41.00   3rd Qu.:1.000  
 Max.   :67.10   Max.   :2.4200           Max.   :81.00   Max.   :1.000  

str(diabetes)

'data.frame':   768 obs. of  9 variables:
 $ Pregnancies             : int  6 1 8 1 0 5 3 10 2 8 ...
 $ Glucose                 : int  148 85 183 89 137 116 78 115 197 125 ...
 $ BloodPressure           : int  72 66 64 66 40 74 50 0 70 96 ...
 $ SkinThickness           : int  35 29 0 23 35 0 32 0 45 0 ...
 $ Insulin                 : int  0 0 0 94 168 0 88 0 543 0 ...
 $ BMI                     : num  33.6 26.6 23.3 28.1 43.1 25.6 31 35.3 30.5 0 ...
 $ DiabetesPedigreeFunction: num  0.627 0.351 0.672 0.167 2.288 ...
 $ Age                     : int  50 31 32 21 33 30 26 29 53 54 ...
 $ Outcome                 : int  1 0 1 0 1 0 1 0 1 1 ...

Pre-processing

# removing those observation rows with 0 in any of the variables
for (i in 2:6) {
      diabetes <- diabetes[-which(diabetes[, i] == 0), ]
}
# scale the covariates for easier comparison of coefficient posteriors
for (i in 1:8) {
      diabetes[i] <- scale(diabetes[i])
}

# modify the data column names slightly for easier typing
names(diabetes)[7] <- "dpf"
names(diabetes) <- tolower(names(diabetes))

n=dim(diabetes)[1]
p=dim(diabetes)[2]
str(diabetes)

'data.frame':   392 obs. of  9 variables:
 $ pregnancies  : num [1:392, 1] -0.7165 -1.0279 -0.0937 -0.4051 -0.7165 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:392] "4" "5" "7" "9" ...
  .. ..$ : chr "Pregnancies"
  ..- attr(*, "scaled:center")= Named num 3.3
  .. ..- attr(*, "names")= chr "Pregnancies"
  ..- attr(*, "scaled:scale")= Named num 3.21
  .. ..- attr(*, "names")= chr "Pregnancies"
 $ glucose      : num [1:392, 1] -1.09 0.466 -1.446 2.41 2.151 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:392] "4" "5" "7" "9" ...
  .. ..$ : chr "Glucose"
  ..- attr(*, "scaled:center")= Named num 123
  .. ..- attr(*, "names")= chr "Glucose"
  ..- attr(*, "scaled:scale")= Named num 30.9
  .. ..- attr(*, "names")= chr "Glucose"
 $ bloodpressure: num [1:392, 1] -0.3732 -2.4538 -1.6536 -0.0531 -0.8533 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:392] "4" "5" "7" "9" ...
  .. ..$ : chr "BloodPressure"
  ..- attr(*, "scaled:center")= Named num 70.7
  .. ..- attr(*, "names")= chr "BloodPressure"
  ..- attr(*, "scaled:scale")= Named num 12.5
  .. ..- attr(*, "names")= chr "BloodPressure"
 $ skinthickness: num [1:392, 1] -0.584 0.557 0.271 1.508 -0.584 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:392] "4" "5" "7" "9" ...
  .. ..$ : chr "SkinThickness"
  ..- attr(*, "scaled:center")= Named num 29.1
  .. ..- attr(*, "names")= chr "SkinThickness"
  ..- attr(*, "scaled:scale")= Named num 10.5
  .. ..- attr(*, "names")= chr "SkinThickness"
 $ insulin      : num [1:392, 1] -0.522 0.101 -0.573 3.256 5.806 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:392] "4" "5" "7" "9" ...
  .. ..$ : chr "Insulin"
  ..- attr(*, "scaled:center")= Named num 156
  .. ..- attr(*, "names")= chr "Insulin"
  ..- attr(*, "scaled:scale")= Named num 119
  .. ..- attr(*, "names")= chr "Insulin"
 $ bmi          : num [1:392, 1] -0.71 1.425 -0.297 -0.368 -0.425 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:392] "4" "5" "7" "9" ...
  .. ..$ : chr "BMI"
  ..- attr(*, "scaled:center")= Named num 33.1
  .. ..- attr(*, "names")= chr "BMI"
  ..- attr(*, "scaled:scale")= Named num 7.03
  .. ..- attr(*, "names")= chr "BMI"
 $ dpf          : num [1:392, 1] -1.031 5.109 -0.796 -1.057 -0.362 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:392] "4" "5" "7" "9" ...
  .. ..$ : chr "DiabetesPedigreeFunction"
  ..- attr(*, "scaled:center")= Named num 0.523
  .. ..- attr(*, "names")= chr "DiabetesPedigreeFunction"
  ..- attr(*, "scaled:scale")= Named num 0.345
  .. ..- attr(*, "names")= chr "DiabetesPedigreeFunction"
 $ age          : num [1:392, 1] -0.967 0.209 -0.477 2.17 2.758 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:392] "4" "5" "7" "9" ...
  .. ..$ : chr "Age"
  ..- attr(*, "scaled:center")= Named num 30.9
  .. ..- attr(*, "names")= chr "Age"
  ..- attr(*, "scaled:scale")= Named num 10.2
  .. ..- attr(*, "names")= chr "Age"
 $ outcome      : int  0 1 1 1 1 1 1 0 1 0 ...

print(paste0("number of observations = ", n))

[1] "number of observations = 392"

print(paste0("number of predictors = ", p))

[1] "number of predictors = 9"

Plot correlation structure

corrplot(cor(diabetes[, c(9,1:8)]))

Make outcome to be factor type and create x and y variables

diabetes$outcome <- factor(diabetes$outcome)
# preparing the inputs
x <- model.matrix(outcome ~ . - 1, data = diabetes)
y <- diabetes$outcome
(reg_formula <- formula(paste("outcome ~", paste(names(diabetes)[1:(p-1)], collapse = " + "))))

outcome ~ pregnancies + glucose + bloodpressure + skinthickness + 
    insulin + bmi + dpf + age

4 A Bayesian logistic regression model

A Bayesian logistic regression model can be estimated using the stan_glm function. Here we’ll use a Student t prior with 7 degrees of freedom and a scale of 2.5, which, as discussed above, is a reasonable default prior when coefficients should be close to zero but have some chance of being large.

The formula, data and family arguments to stan_glm are specified in exactly the same way as for glm. We’ve also added the seed (for reproducibility). You can read about other possible arguments in the stan_glm documentation (help(stan_glm, package = 'rstanarm')).

t_prior <- student_t(df = 7, location = 0, scale = 2.5)
post1 <- stan_glm(reg_formula, data = diabetes,
                 family = binomial(link = "logit"), 
                 prior = t_prior, prior_intercept = t_prior, QR=TRUE,
                 seed = SEED, refresh=0)

stan_glm returns the posterior distribution for the parameters describing the uncertainty related to unknown parameter values:

pplot<-plot(post1, "areas", prob = 0.95, prob_outer = 1)
pplot+ geom_vline(xintercept = 0)

We can extract corresponding posterior median estimates using ‘coef’ function and to get a sense for the uncertainty in our estimates we can use the posterior_interval function to get Bayesian uncertainty intervals. The uncertainty intervals are computed by finding the relevant quantiles of the draws from the posterior distribution. For example, to compute median and 90% intervals we use:

round(coef(post1), 2)

  (Intercept)   pregnancies       glucose bloodpressure skinthickness       insulin 
        -1.01          0.26          1.20         -0.02          0.12         -0.10 
          bmi           dpf           age 
         0.50          0.40          0.35 

round(posterior_interval(post1, prob = 0.9), 2)

                 5%   95%
(Intercept)   -1.25 -0.78
pregnancies   -0.03  0.55
glucose        0.92  1.51
bloodpressure -0.27  0.24
skinthickness -0.19  0.43
insulin       -0.36  0.16
bmi            0.19  0.82
dpf            0.16  0.64
age            0.04  0.67

For more on posterior_interval and interpreting the parameter estimates from a Bayesian model see Step 2 in the “How to Use the rstanarm Package” vignette.

4.1 Leave-one-out cross-validation

rstanarm supports loo package which implements fast Pareto smoothed leave-one-out cross-validation (PSIS-LOO) (Vehtari, Gelman and Gabry, 2017b) to compute expected log predictive density (elpd):

(loo1 <- loo(post1, save_psis = TRUE))

Computed from 4000 by 392 log-likelihood matrix

         Estimate   SE
elpd_loo   -182.4 11.9
p_loo        11.0  1.4
looic       364.7 23.8
------
Monte Carlo SE of elpd_loo is 0.1.

All Pareto k estimates are good (k < 0.5).
See help('pareto-k-diagnostic') for details.

Above we see that PSIS-LOO result is reliable as all Pareto \(k\) estimates are small (k< 0.5) Vehtari, Gelman and Gabry (2017a).

4.2 Comparison to a baseline model

Compute baseline result without covariates.

post0 <- update(post1, formula = outcome ~ 1, QR = FALSE, refresh=0)

Compare to baseline

(loo0 <- loo(post0))

Computed from 4000 by 392 log-likelihood matrix

         Estimate   SE
elpd_loo   -250.0  6.6
p_loo         1.0  0.0
looic       500.0 13.2
------
Monte Carlo SE of elpd_loo is 0.0.

All Pareto k estimates are good (k < 0.5).
See help('pareto-k-diagnostic') for details.

loo_compare(loo0, loo1)

      elpd_diff se_diff
post1   0.0       0.0  
post0 -67.6      11.5  

Covariates contain clearly useful information for predictions.

4.3 Other predictive performance measures

For more easily interpretable predictive performance measures, we next compute posterior predictive probabilities and use them to compute classification error.

# Predicted probabilities
linpred <- posterior_linpred(post1)
preds <- posterior_epred(post1)
pred <- colMeans(preds)
pr <- as.integer(pred >= 0.5)
   
# posterior classification accuracy
round(mean(xor(pr,as.integer(y==0))),2)

[1] 0.78

# posterior balanced classification accuracy
round((mean(xor(pr[y==0]>0.5,as.integer(y[y==0])))+mean(xor(pr[y==1]<0.5,as.integer(y[y==1]))))/2,2)

[1] 0.73

The predictive performance above is overoptimistic. To better estimate the predictive performance for new not yet seen data we next use leave-one-out cross-validation:

# LOO predictive probabilities
ploo=E_loo(preds, loo1$psis_object, type="mean", log_ratios = -log_lik(post1))$value
# LOO classification accuracy
round(mean(xor(ploo>0.5,as.integer(y==0))),2)

[1] 0.78

# LOO balanced classification accuracy
round((mean(xor(ploo[y==0]>0.5,as.integer(y[y==0])))+mean(xor(ploo[y==1]<0.5,as.integer(y[y==1]))))/2,2)

[1] 0.72

In this case it happens that all predicted classes are same as with posterior predictions. We can see the small difference in posterior predictive probabilities and LOO probabilities:

qplot(pred, ploo)

4.4 Calibration of predictions

We can also examine calibration of the posterior and LOO predictive probabilities compared to observed binned event rates. We sort the predicted probabilities in ascending order, bin the corresponding binary observations and plot the mean and uncertainty interval based on binomial distribution.

calPlotData<-calibration(y ~ pred + loopred, 
                         data = data.frame(pred=pred,loopred=ploo,y=y), 
                         cuts=10, class="1")
ggplot(calPlotData, auto.key = list(columns = 2))+
  scale_colour_brewer(palette = "Set1")

From the above calibration plot we see that the model is otherwise calibrated except that for the observations with highest 10% of the predicted probabilities there are less events than predicted.

The above calibration plot is using independent bins for the observations. The following uses a spline fit for smoothing (with narrower uncertainties).

library(splines)
library(MASS)
ggplot(data = data.frame(pred=pred,loopred=ploo,y=as.numeric(y)-1), aes(x=loopred, y=y)) +
  stat_smooth(method='glm', formula = y ~ ns(x, 5), fullrange=TRUE) +
  geom_abline(linetype = 'dashed') +
  labs(x = "Predicted (LOO)", y = "Observed") +
  geom_jitter(height=0.02, width=0, alpha=0.3) +
  scale_y_continuous(breaks=seq(0,1,by=0.1)) +
  xlim(c(0,1))

Dimitriadis, Gneiting, Jordan (2021) proposed recently a new CORP approach for assessing calibration (or reliability as they call it) that uses nonparametric isotonic regression and the pool-adjacent-violators (PAV) algorithm to estimate conditional event probabilities (CEPs) with automated choice of bins.

library(reliabilitydiag)
rd=reliabilitydiag(EMOS = ploo, y = as.numeric(y)-1)
autoplot(rd)+
  labs(x="Predicted (LOO)",
       y="Conditional event probabilities")+
  bayesplot::theme_default(base_family = "sans")

5 Alternative horseshoe prior on weights.

In this example, with n>>p the difference is small, and thus we don’t expect much difference with a different prior and regularized horseshoe prior (Piironen and Vehtari, 2017) is usually more useful for n<p. 

The global scale parameter for horseshoe prior is chosen as recommended by Piironen and Vehtari (2017). To prepare for projection predictive variable selection we

p0 <- 2 # prior guess for the number of relevant variables
tau0 <- p0/(p-p0) * 1/sqrt(n)
hs_prior <- hs(df=1, global_df=1, global_scale=tau0)
t_prior <- student_t(df = 7, location = 0, scale = 2.5)
post2 <- stan_glm(reg_formula, data = diabetes,
                 family = binomial(link = "logit"), 
                 prior = hs_prior, prior_intercept = t_prior,
                 seed = SEED, adapt_delta = 0.999, refresh=0)

We see that the regularized horseshoe prior has shrunk the posterior distribution of irrelevant features closer to zero, without affecting the posterior distribution of the relevant features.

pplot <- plot(post2, "areas", prob = 0.95, prob_outer = 1)
pplot + geom_vline(xintercept = 0)

round(coef(post2), 2)

  (Intercept)   pregnancies       glucose bloodpressure skinthickness       insulin 
        -0.98          0.17          1.13          0.00          0.07         -0.01 
          bmi           dpf           age 
         0.41          0.30          0.33 

round(posterior_interval(post2, prob = 0.9), 2)

                 5%   95%
(Intercept)   -1.22 -0.75
pregnancies   -0.03  0.50
glucose        0.88  1.42
bloodpressure -0.14  0.18
skinthickness -0.07  0.38
insulin       -0.21  0.13
bmi            0.05  0.71
dpf            0.03  0.57
age            0.00  0.64

We compute LOO also for the model with the regularized horseshoe prior. Expected log predictive density is higher, but not significantly. This is not surprising as this is a easy data with n>>p.

(loo2 <- loo(post2))

Computed from 4000 by 392 log-likelihood matrix

         Estimate   SE
elpd_loo   -181.7 11.2
p_loo         9.5  1.3
looic       363.5 22.3
------
Monte Carlo SE of elpd_loo is 0.1.

All Pareto k estimates are good (k < 0.5).
See help('pareto-k-diagnostic') for details.

loo_compare(loo1, loo2)

      elpd_diff se_diff
post2  0.0       0.0   
post1 -0.6       1.3   

Looking at the pairwise posteriors we can see that, for example, posteriors for age and pregnancies effects are correlating and thus we can’t relay on infering variable relevance by looking at the marginal distributions.

mcmc_pairs(as.matrix(post2), pars = c("pregnancies","age"))

6 Projection predictive variable selection

Next we do variable selection using projection predictive variable selection (Piironen, Paasiniemi and Vehtari, 2020)

varsel2 <- cv_varsel(post2, method='forward', cv_method='loo', nloo = n)

We get a LOO based recommendation for the model size and the selected variables.

(nsel<-suggest_size(varsel2))

[1] 3

(vsel<-solution_terms(varsel2)[1:nsel])

[1] "glucose" "age"     "bmi"    

We can now look at the estimated predictive performance of smaller models compared to the full model.

plot(varsel2, stats = c('elpd', 'pctcorr'), deltas=FALSE)

Next we form the projected posterior for the chosen model.

proj2 <- project(varsel2, nv = nsel, ns = 4000)
proj2draws <- as.matrix(proj2)
colnames(proj2draws) <- c("Intercept",vsel)
round(colMeans(proj2draws),1)

Intercept   glucose       age       bmi 
     -1.0       1.1       0.5       0.5 

round(posterior_interval(proj2draws),1)

            5%  95%
Intercept -1.2 -0.8
glucose    0.9  1.4
age        0.3  0.7
bmi        0.2  0.7

mcmc_areas(proj2draws, prob = 0.95, prob_outer = 1,
           pars = c('Intercept', vsel))

The projected posterior can be made predictions in the future (with no need to measure the left out variables).

7 Additive non-linear model

We also test an additive non-linear model using stan_gamm4.

post3 <- stan_gamm4(outcome ~ s(glucose) + s(age) + s(bmi) + s(dpf), data = diabetes,
                 family = binomial(link = "logit"), 
                 seed = SEED, refresh=0)

(loo3 <- loo(post3, save_psis = TRUE))

Computed from 4000 by 392 log-likelihood matrix

         Estimate   SE
elpd_loo   -176.0 10.8
p_loo         9.3  1.1
looic       352.1 21.6
------
Monte Carlo SE of elpd_loo is 0.1.

Pareto k diagnostic values:
                         Count Pct.    Min. n_eff
(-Inf, 0.5]   (good)     390   99.5%   1224      
 (0.5, 0.7]   (ok)         2    0.5%   2360      
   (0.7, 1]   (bad)        0    0.0%   <NA>      
   (1, Inf)   (very bad)   0    0.0%   <NA>      

All Pareto k estimates are ok (k < 0.7).
See help('pareto-k-diagnostic') for details.

loo_compare(loo1, loo3)

      elpd_diff se_diff
post3  0.0       0.0   
post1 -6.3       3.6   

Based on LOO, non-linear model might be better, but the difference is not big.

Let’s look at the calibration.

gammpreds <- posterior_epred(post3)
gammpred <- colMeans(gammpreds)
loogammpred=E_loo(gammpreds, loo3$psis_object, type="mean", log_ratios = -log_lik(post3))$value
calPlotData<-calibration(y ~ loopred + loogammpred, 
                         data = data.frame(loopred=ploo,loogammpred=loogammpred,y=y),
                         cuts=10, class="1")
ggplot(calPlotData, auto.key = list(columns = 2))

Non-linear model appears to be able to partially model the saturating high probabilities and is thus slighlty better calibrated.

The above calibration plot is using independent bins for the observations. The following uses a spline fit for smoothing (with narrower uncertainties).

ggplot(data = data.frame(loopred=loogammpred,y=as.numeric(y)-1), aes(x=loopred, y=y)) + stat_smooth(method='glm', formula = y ~ ns(x, 5), fullrange=TRUE) + geom_abline(linetype = 'dashed') + ylab(label = "Observed") + xlab(label = "Predicted (LOO)") + geom_jitter(height=0.02, width=0, alpha=0.3) + scale_y_continuous(breaks=seq(0,1,by=0.1)) + xlim(c(0,1))

And the new CORP calibration plot.

rd=reliabilitydiag(EMOS = loogammpred, y = as.numeric(y)-1)
autoplot(rd)+
  labs(x="Predicted (LOO)",
       y="Conditional event probabilities")+
  bayesplot::theme_default(base_family = "sans")

References

Piironen, J., Paasiniemi, M. and Vehtari, A. (2020) ‘Projective inference in high-dimensional problems: Prediction and feature selection’, Electronic Journal of Statistics, 14(1), pp. 2155–2197.

Piironen, J. and Vehtari, A. (2017) ‘Sparsity information and regularization in the horseshoe and other shrinkage priors’, Electronic journal of Statistics, 11(2), pp. 5018–5051. doi: 10.1214/17-EJS1337SI.

Vehtari, A., Gelman, A. and Gabry, J. (2017a) ‘Pareto smoothed importance sampling’, arXiv preprint arXiv:1507.02646. Available at: https://arxiv.org/abs/1507.02646.

Vehtari, A., Gelman, A. and Gabry, J. (2017b) ‘Practical Bayesian model evaluation using leave-one-out cross-validation and WAIC’, Statistics and Computing, 27(5), pp. 1413–1432. doi: 10.1007/s11222-016-9696-4.

Licenses

• Code © 2017-2018, Aki Vehtari, licensed under BSD-3.
• Text © 2017-2018, Aki Vehtari, licensed under CC-BY-NC 4.0.
• Introduction Text © 2017, Jonah Gabry and Ben Goodrich source, licensed under GPL 3>

Original Computing Environment

sessionInfo()

R version 4.1.2 (2021-11-01)
Platform: x86_64-pc-linux-gnu (64-bit)
Running under: Ubuntu 20.04.3 LTS

Matrix products: default
BLAS/LAPACK: /opt/OpenBLAS/lib/libopenblas_haswellp-r0.3.17.so

locale:
 [1] LC_CTYPE=en_US.UTF-8       LC_NUMERIC=C               LC_TIME=fi_FI.UTF-8       
 [4] LC_COLLATE=en_US.UTF-8     LC_MONETARY=fi_FI.UTF-8    LC_MESSAGES=en_US.UTF-8   
 [7] LC_PAPER=fi_FI.UTF-8       LC_NAME=C                  LC_ADDRESS=C              
[10] LC_TELEPHONE=C             LC_MEASUREMENT=fi_FI.UTF-8 LC_IDENTIFICATION=C       

attached base packages:
[1] splines   stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
 [1] reliabilitydiag_0.2.0 MASS_7.3-55           corrplot_0.92         caret_6.0-90         
 [5] lattice_0.20-45       GGally_2.1.2          fivethirtyeight_0.6.2 projpred_2.0.2       
 [9] bayesplot_1.8.1       forcats_0.5.1         stringr_1.4.0         dplyr_1.0.8          
[13] purrr_0.3.4           readr_2.1.2           tidyr_1.2.0           tibble_3.1.6         
[17] ggplot2_3.3.5         tidyverse_1.3.1       loo_2.4.1             rstanarm_2.21.1      
[21] Rcpp_1.0.8            rmarkdown_2.11        knitr_1.37           

loaded via a namespace (and not attached):
  [1] readxl_1.3.1         backports_1.4.1      plyr_1.8.6           igraph_1.2.11       
  [5] listenv_0.8.0        crosstalk_1.2.0      usethis_2.1.5        rstantools_2.1.1    
  [9] inline_0.3.19        digest_0.6.29        foreach_1.5.2        htmltools_0.5.2     
 [13] rsconnect_0.8.25     fansi_1.0.2          magrittr_2.0.2       checkmate_2.0.0     
 [17] memoise_2.0.1        tzdb_0.2.0           remotes_2.4.2        globals_0.14.0      
 [21] recipes_0.1.17       gower_1.0.0          modelr_0.1.8         RcppParallel_5.1.5  
 [25] matrixStats_0.61.0   xts_0.12.1           prettyunits_1.1.1    colorspace_2.0-2    
 [29] rvest_1.0.2          haven_2.4.3          xfun_0.29            callr_3.7.0         
 [33] crayon_1.4.2         jsonlite_1.7.3       lme4_1.1-28          iterators_1.0.14    
 [37] survival_3.2-13      zoo_1.8-9            glue_1.6.1           gtable_0.3.0        
 [41] ipred_0.9-12         distributional_0.3.0 pkgbuild_1.3.1       rstan_2.21.3        
 [45] future.apply_1.8.1   abind_1.4-5          scales_1.1.1         DBI_1.1.2           
 [49] miniUI_0.1.1.1       progress_1.2.2       xtable_1.8-4         lava_1.6.10         
 [53] prodlim_2019.11.13   stats4_4.1.2         StanHeaders_2.21.0-7 DT_0.20             
 [57] htmlwidgets_1.5.4    httr_1.4.2           threejs_0.3.3        RColorBrewer_1.1-2  
 [61] posterior_1.2.0      ellipsis_0.3.2       reshape_0.8.8        pkgconfig_2.0.3     
 [65] farver_2.1.0         nnet_7.3-17          sass_0.4.0           dbplyr_2.1.1        
 [69] utf8_1.2.2           labeling_0.4.2       tidyselect_1.1.1     rlang_1.0.1         
 [73] reshape2_1.4.4       later_1.3.0          munsell_0.5.0        cellranger_1.1.0    
 [77] tools_4.1.2          cachem_1.0.6         cli_3.1.1            generics_0.1.2      
 [81] devtools_2.4.3       broom_0.7.12         ggridges_0.5.3       evaluate_0.14       
 [85] fastmap_1.1.0        yaml_2.2.2           ModelMetrics_1.2.2.2 processx_3.5.2      
 [89] fs_1.5.2             future_1.23.0        nlme_3.1-155         mime_0.12           
 [93] xml2_1.3.3           brio_1.1.3           compiler_4.1.2       shinythemes_1.2.0   
 [97] rstudioapi_0.13      gamm4_0.2-6          testthat_3.1.2       reprex_2.0.1        
[101] bslib_0.3.1          stringi_1.7.6        highr_0.9            ps_1.6.0            
[105] desc_1.4.0           Matrix_1.4-0         nloptr_1.2.2.3       markdown_1.1        
[109] shinyjs_2.1.0        tensorA_0.36.2       vctrs_0.3.8          pillar_1.7.0        
[113] lifecycle_1.0.1      jquerylib_0.1.4      data.table_1.14.2    httpuv_1.6.5        
[117] R6_2.5.1             promises_1.2.0.1     gridExtra_2.3        parallelly_1.30.0   
[121] sessioninfo_1.2.2    codetools_0.2-18     boot_1.3-28          colourpicker_1.1.1  
[125] gtools_3.9.2         assertthat_0.2.1     pkgload_1.2.4        rprojroot_2.0.2     
[129] withr_2.4.3          shinystan_2.5.0      mgcv_1.8-38          parallel_4.1.2      
[133] hms_1.1.1            rpart_4.1.16         timeDate_3043.102    grid_4.1.2          
[137] class_7.3-20         minqa_1.2.4          pROC_1.18.0          shiny_1.7.1         
[141] lubridate_1.8.0      base64enc_0.1-3      dygraphs_1.1.1.6