Physical activity flow propensity

The R code below first loads rstan and pcFactorStan. For extra diagnostics, we also load loo.

library(rstan)
library(pcFactorStan)
library(loo)

Next we take a peek at the data.

head(phyActFlowPropensity)

pa1	pa2	skill	predict	novelty	creative	complex	goal1	feedback1	chatter	waiting	body	control	present	spont	stakes	evaluated	reward
mountain biking	tennis	1	-1	-2	1	1	1	1	-2	1	1	1	1	1	1	2	0
mountain biking	tennis	1	2	-1	-1	-1	0	2	1	2	0	1	0	0	1	2	-1
ice skating	running	-2	1	-1	-2	-1	1	1	-2	-2	-1	0	0	-1	-1	-1	0
climbing	rowing	-2	2	-2	-2	-2	0	-1	-1	-1	-1	-1	-1	1	0	0	0
card game	gardening	0	0	0	0	2	0	0	0	-2	2	1	0	0	2	-2	2
dance	table tennis	0	-2	-1	-1	0	-1	-1	-1	0	0	0	0	0	0	0	1

These data consist of paired comparisons of 87 physical activities on 16 flow-related facets. Participants submitted two activities using free-form input. These activities were substituted into item templates. For example, Item predict consisted of the prompt, “How predictable is the action?” with response options:

• A1 is much more predictable than A2.
• A1 is somewhat more predictable than A2.
• Both offer roughly equal predictability.
• A2 is somewhat more predictable than A1.
• A2 is much more predictable than A1.

If the participant selected ‘golf’ and ‘running’ for activities then ‘golf’ was substituted into A1 and ‘running’ into A2. Duly prepared, the item was presented and the participant asked to select the most plausible statement.

A somewhat more response is scored 1 or -1 and much more scored 2 or -2. A tie (i.e. roughly equal) is scored as zero. We will need to analyze each item separately before we analyze them together. Therefore, we will start with Item skill.

Data must be fed into Stan in a partially digested form. The next block of code demonstrates how a suitable data list may be constructed using the prepData() function. This function automatically determines the number of threshold parameters based on the range observed in your data. One thing it does not do is pick a varCorrection factor. The varCorrection determines the degree of adaption in the model. Usually some choice between 2.0 to 4.0 will obtain optimal results.

dl <- prepData(phyActFlowPropensity[,c(paste0('pa',1:2), 'skill')])
dl$varCorrection <- 2.0

Next we fit the model using the pcStan() function, which is a wrapper for stan() from rstan. We also choose the number of chains. As is customary Stan procedure, the first half of each chain is used to estimate the sampler’s weight matrix (i.e. warm up) and excluded from inference.

fit1 <- pcStan("unidim_adapt", data=dl)

A variety of diagnostics are available to check whether the sampler ran into trouble.

check_hmc_diagnostics(fit1)
#> 
#> Divergences:
#> 0 of 4000 iterations ended with a divergence.
#> 
#> Tree depth:
#> 0 of 4000 iterations saturated the maximum tree depth of 10.
#> 
#> Energy:
#> E-BFMI indicated no pathological behavior.

Everything looks good, but there are a few more things to check. We want \(\widehat R\) < 1.015 and effective sample size greater than 100 times the number of chains (Vehtari et al., 2019).

allPars <- summary(fit1, probs=c())$summary 
print(min(allPars[,'n_eff']))
#> [1] 675.4
print(max(allPars[,'Rhat']))
#> [1] 1.005

Again, everything looks good. If the target values were not reached then we would sample the model again with more iterations. Time for a plot,

library(ggplot2)

theta <- summary(fit1, pars=c("theta"), probs=c())$summary[,'mean']

ggplot(data.frame(x=theta, activity=dl$nameInfo$pa, y=0.47)) +
  geom_point(aes(x=x),y=0) +
  geom_text(aes(label=activity, x=x, y=y),
            angle=85, hjust=0, size=2,
            position = position_jitter(width = 0, height = 0.4)) + ylim(0,1) +
  theme(legend.position="none",
        axis.title.x=element_blank(),
        axis.title.y=element_blank(),
        axis.text.y=element_blank(),
        axis.ticks.y=element_blank())

Intuitively, this seems like a fairly reasonable ranking for skill. As pretty as the plot is, the main reason that we fit this model was to find a scaling constant to produce a standard deviation close to 1.0,

s50 <- summary(fit1, pars=c("scale"), probs=c(.5))$summary[,'50%']
print(s50)
#> [1] 0.5877

We use the median instead of the mean because scale is not likely to have a symmetric marginal posterior distribution. We obtained 0.5877, but that value is just for one item. We have to perform the same procedure for every item. Wow, that would be really tedious … if we did not have a function to do it for us! Fortunately, calibrateItems takes care of it and produces a table of the pertinent data,

result <- calibrateItems(phyActFlowPropensity, iter=1000L) 

print(result)

item	iter	divergent	treedepth	low_bfmi	n_eff	Rhat	scale	thetaVar
skill	1000	0	0	0	492.46	1.007	0.5901	1.0213
predict	1000	0	0	0	641.66	1.003	0.5686	0.9963
novelty	1000	0	0	0	774.62	1.004	0.4728	0.8811
creative	1000	0	0	0	690.77	1.004	0.4692	0.8765
complex	1000	0	0	0	467.95	1.007	0.5349	0.9566
goal1	1000	0	0	1	94.72	1.030	0.0869	0.2848
feedback1	3375	0	0	0	435.95	1.002	0.1567	0.4220
chatter	1000	0	0	0	1024.80	1.002	0.2468	0.5712
waiting	1000	0	0	0	532.23	1.003	0.4969	0.9106
body	1000	0	0	0	960.07	1.003	0.3628	0.7385
control	1000	0	0	0	1030.68	1.004	0.3149	0.6719
present	1000	0	0	0	1059.55	1.005	0.2365	0.5551
spont	1000	0	0	0	1231.19	1.001	0.2622	0.5947
stakes	1000	0	0	0	889.16	1.001	0.2801	0.6214
evaluated	1500	0	0	0	988.22	1.004	0.4423	0.8427
reward	1000	0	0	0	898.49	1.012	0.2165	0.5234

Item goal1 ran into trouble. A nonzero count of divergent transitions or low_bfmi means that the item contained too little signal to estimate. Item feedback1 is also prone to failure. We could try again with varCorrection=1.0, but we are going to exclude these items instead. The model succeeded on the rest of the items. I requested iter=1000L to demonstrate how calibrateItems will resample the model until the n_eff is large enough and the Rhat small enough. As demonstrated in the iter column, some items needed more than 1000 samples to converge.

Next we will fit the correlation model. We exclude the Cholesky factor of the correlation matrix rawThetaCorChol because the regular correlation matrix is also output.

pafp <- phyActFlowPropensity 
excl <- match(c('goal1','feedback1'), colnames(pafp))
pafp <- pafp[,-excl]
dl <- prepData(pafp)
dl$scale <- result[-excl,'scale'] 

fit2 <- pcStan("correlation", data=dl, include=FALSE, pars=c('rawTheta', 'rawThetaCorChol'))

check_hmc_diagnostics(fit2)
#> 
#> Divergences:
#> 0 of 4000 iterations ended with a divergence.
#> 
#> Tree depth:
#> 0 of 4000 iterations saturated the maximum tree depth of 10.
#> 
#> Energy:
#> E-BFMI indicated no pathological behavior.

allPars <- summary(fit2, probs=0.5)$summary 
print(min(allPars[,'n_eff']))
#> [1] NaN
print(max(allPars[,'Rhat']))
#> [1] NaN

The HMC diagnostics look good, but … oh dear! Something is wrong with the n_eff and \(\widehat R\). Let us look more carefully,

head(allPars[order(allPars[,'sd']),])
#>               mean   se_mean        sd 50%  n_eff  Rhat
#> thetaCor[1,1]    1       NaN 0.000e+00   1    NaN   NaN
#> thetaCor[3,3]    1 1.264e-18 6.303e-17   1 2487.0 0.999
#> thetaCor[2,2]    1 1.030e-18 6.347e-17   1 3798.2 0.999
#> thetaCor[4,4]    1 4.778e-18 6.925e-17   1  210.1 0.999
#> thetaCor[5,5]    1 1.468e-18 7.042e-17   1 2302.7 0.999
#> thetaCor[7,7]    1 1.512e-18 7.725e-17   1 2609.9 0.999

Ah ha! It looks like all the entries of the correlation matrix are reported, including the entries that are not stochastic but are fixed to constant values. We need to filter those out to get sensible results.

allPars <- allPars[allPars[,'sd'] > 1e-6,] 
print(min(allPars[,'n_eff']))
#> [1] 971.2
print(max(allPars[,'Rhat']))
#> [1] 1.003

Ah, much better. Now we can inspect the correlation matrix. There are many ways to visualize a correlation matrix. One of my favorite ways is to plot it using the qgraph package,

covItemNames <- dl$nameInfo$item 
tc <- summary(fit2, pars=c("thetaCor"), probs=c(.5))$summary[,'50%']
tcor <- matrix(tc, length(covItemNames), length(covItemNames))
dimnames(tcor) <- list(covItemNames, covItemNames)

library(qgraph)
#> Registered S3 methods overwritten by 'huge':
#>   method    from   
#>   plot.sim  BDgraph
#>   print.sim BDgraph
qgraph(tcor, layout = "spring", graph = "cor", labels=colnames(tcor),
       legend.cex = 0.3,
       cut = 0.3, maximum = 1, minimum = 0, esize = 20,
       vsize = 7, repulsion = 0.8, negDashed=TRUE, theme="colorblind")

Based on this plot and theoretical considerations, I decided to exclude spont, control, evaluated, and waiting from the factor model. A detailed rationale for why these items, and not others, are excluded will be presented in a forthcoming article. For now, let us focus on the mechanics of data analysis. Here are item response curves,

df <- responseCurve(dl, fit2,
  item=setdiff(dl$nameInfo$item, c('spont','control','evaluated','waiting')),
  responseNames=c("much more","somewhat more", 'equal',
                  "somewhat less", "much less"))
ggplot(df) +
  geom_line(aes(x=worthDiff,y=prob,color=response,linetype=response,
                group=responseSample), size=.2, alpha=.2) +
  xlab("difference in latent worths") + ylab("probability") +
  ylim(0,1) + facet_wrap(~item) +
    guides(color=guide_legend(override.aes=list(alpha = 1, size=1)))

These response curves are a function of the thresholds, scale, and alpha parameters. A detailed description of the item response model can be found in the man page for responseCurve. A large alpha (>1) can mean that the item discriminates among objects well. However, it can also mean that the model predicts all responses will be equal. If most observed responses are indeed equal then this can result in good model fit, but we can also infer that the item is useless.

alpha <- summary(fit2, pars=c("alpha"), probs=c(.5))$summary
rownames(alpha) <- covItemNames

print(alpha[alpha[,'sd']>.25,,drop=FALSE])

	mean	se_mean	sd	50%	n_eff	Rhat
chatter	2.046	0.0084	0.4039	2.016	2309	1.002
waiting	2.905	0.0076	0.3972	2.873	2766	1.000

I already decided to exclude waiting by inspection of the correlation matrix. Item chatter is on the borderline, but we can retain it.

We will enter the alpha parameters into the factor model as non-stochastic data. Trying to estimate alpha in the factor model causes bias, at least in the models that I have tried. The factor model is prone to increase both alpha and the magnitude of factor proportions at the expense of threshold accuracy. To treat alpha as non-stochastic reduces variability in the factor model, but not by much. Simulations indicate that the posterior distribution remains well calibrated.

I will fit model ‘factor_ll’ instead of ‘factor’ so I can use the loo package to look for outliers. We also need to take care that the data pafp matches, one-to-one, the data seen by Stan so we can map back from the model to the data. Hence, we update pafp using the usual the data cleaning sequence of filterGraph and normalizeData and pass the result to prepCleanData.

Up until version 1.0.2, only a single factor model was available. As of 1.1.0, the factor model supports an arbitrary number of factors and arbitrary factor-to-item structure. In this example, we will keep with the simplest factor model, a single factor that predicts all items. We need to set a prior on the factor loadings. The prior is given as the standard deviation of the normal prior for the logit transformed factor proportion. Here’s an example:

factorProportion <- .3
factorScalePrior <- .9
dnorm(qlogis(0.5 + factorProportion/2), sd=factorScalePrior)
#> [1] 0.3499

Enough data are available that we can use a factor scale prior of 1.0. If the model exhibited sampling difficulties (i.e. divergences) then a smaller prior could help by constraining the factor proportion closer to zero.

pafp <- pafp[,c(paste0('pa',1:2),
             setdiff(covItemNames, c('spont','control','evaluated','waiting')))]
pafp <- normalizeData(filterGraph(pafp))
dl <- prepCleanData(pafp)
dl <- prepSingleFactorModel(dl, 1.0)
dl$scale <- result[match(dl$nameInfo$item, result$item), 'scale']
dl$alpha <- alpha[match(dl$nameInfo$item, rownames(alpha)), 'mean']

fit3 <- pcStan("factor1_ll", data=dl, include=FALSE,
               pars=c('rawUnique', 'rawUniqueTheta', 'rawPerComponentVar',
           'rawFactor', 'rawLoadings', 'rawFactorProp', 'rawNegateFactor', 'rawSeenFactor',
           'unique', 'uniqueTheta'))

To check the fit diagnostics, we have to take care to examine only the parameters of interest. The factor model outputs many parameters that should not be interpreted. For example, we do not care about unique or uniqueTheta, the unique scores.

check_hmc_diagnostics(fit3) 
#> 
#> Divergences:
#> 0 of 4000 iterations ended with a divergence.
#> 
#> Tree depth:
#> 0 of 4000 iterations saturated the maximum tree depth of 10.
#> 
#> Energy:
#> E-BFMI indicated no pathological behavior.

interest <- c("threshold", "pathProp", "factor", "lp__")

allPars <- summary(fit3, pars=interest)$summary
print(min(allPars[,'n_eff']))
#> [1] 600.3
print(max(allPars[,'Rhat']))
#> [1] 1.01

Looks good! Let us see which data are the most unexpected by the model. We create a loo object and inspect the summary output.

options(mc.cores=1)  # otherwise loo consumes too much RAM 
kThreshold <- 0.1
l1 <- toLoo(fit3) 
print(l1)
#> 
#> Computed from 4000 by 9893 log-likelihood matrix
#> 
#>          Estimate    SE
#> elpd_loo -13747.2  62.1
#> p_loo       283.8   5.2
#> looic     27494.4 124.3
#> ------
#> Monte Carlo SE of elpd_loo is 0.3.
#> 
#> All Pareto k estimates are good (k < 0.5).
#> See help('pareto-k-diagnostic') for details.

The estimated Pareto \(k\) estimates are particularly noisy due to the many activities with a small sample size. Sometimes all \(k<0.5\) and sometimes not. We can look at p_loo, the effective number of parameters. In well behaving cases, p_loo is less than the sample size and the number of parameters. This looks good. There are 610 parameters just for the unique scores.

To connect \(k\) statistics with observations, we pass the loo object to outlierTable and use a threshold of 0.1 instead of 0.5 to ensure that we get enough lines. Activities with small sample sizes are retained by filterGraph if they connect other activities because they contribute information to the model. When we look at outliers, we can limit ourselves to activities with a sample size of at least 11.

pa11 <- levels(filterGraph(pafp, minDifferent=11L)$pa1)
ot <- outlierTable(dl, l1, kThreshold)
ot <- subset(ot, pa1 %in% pa11 & pa2 %in% pa11)

print(ot[1:6,])

	pa1	pa2	item	pick	k
32	hockey	snow skiing	complex	-1	0.3631
35	bowling	baseball	body	2	0.3599
44	martial arts	aerobic exercise	creative	2	0.3519
45	skipping rope	volleyball	reward	0	0.3517
49	mountain biking	climbing	reward	2	0.3411
52	running on a treadmill	aerobic exercise	creative	2	0.3375

xx <- which(ot[,'pa1'] == 'mountain biking' & ot[,'pa2'] == 'climbing' & ot[,'item'] == 'predict' & ot[,'pick'] == -2)

	pa1	pa2	item	pick	k
1170	mountain biking	climbing	predict	-2	0.1519

We will take a closer look at row 1170. What does a pick of -2 mean? Pick numbers are converted to response categories by adding the number of thresholds plus one. There are two thresholds (much and somewhat) so 3 + -2 = 1. Looking back at our item response curve plot, the legend gives the response category order from top (1) to bottom (5). The first response category is much more. Putting it all together we obtain an endorsement of mountain biking is much more predictable than climbing. Specifically what about that assertion is unexpected? We can examine how other participants have responded,

pafp[pafp$pa1 == ot[xx,'pa1'] & pafp$pa2 == ot[xx,'pa2'],
     c('pa1','pa2', as.character(ot[xx,'item']))]
#>                 pa1      pa2 predict
#> 563 mountain biking climbing      -2
#> 564 mountain biking climbing      -2

Hm, both participants agreed. Let us look a little deeper to understand why this response was unexpected.

loc <- sapply(ot[xx,c('pa1','pa2','item')], unfactor)
exam <- summary(fit3, pars=paste0("theta[",loc[paste0('pa',1:2)],
                          ",", loc['item'],"]"))$summary
rownames(exam) <- c(as.character(ot[xx,'pa1']), as.character(ot[xx,'pa2']))

	mean	se_mean	sd	2.5%	25%	50%	75%	97.5%	n_eff	Rhat
mountain biking	-0.1298	0.0091	0.4015	-0.9238	-0.3902	-0.1364	0.1408	0.6493	1937	1.001
climbing	-0.7217	0.0105	0.5147	-1.7352	-1.0631	-0.7220	-0.3640	0.2738	2389	1.002

Here we find that mountain biking was estimated 0.5919 units more predictable than climbing, but apparently this ranking was contradicted by most other observations. What sample sizes are associated with these activities?

sum(c(pafp$pa1 == ot[xx,'pa1'], pafp$pa2 == ot[xx,'pa1']))
#> [1] 25
sum(c(pafp$pa1 == ot[xx,'pa2'], pafp$pa2 == ot[xx,'pa2']))
#> [1] 13

Hm, the predictability 95% uncertainty interval for climbing is from -1.7352 to 0.2738. So there is little information. We could continue our investigation by looking at which responses justified these predict estimates. However, let us move on and plot the marginal posterior distributions of the factor proportions,

pi <- parInterval(fit3, 'pathProp', dl$nameInfo$item, label='item')
pi <- pi[order(abs(pi$M)),]
pi$item <- factor(pi$item, levels=pi$item)

ggplot(pi) +
  geom_vline(xintercept=0, color="green") +
  geom_jitter(data=parDistributionFor(fit3, pi),
              aes(value, item), height = 0.35, alpha=.05) +
  geom_segment(aes(y=item, yend=item, x=L, xend=U),
               color="yellow", alpha=.5) +
  geom_point(aes(x=M, y=item), color="red", size=1) +
  theme(axis.title.y=element_blank())

Finally, we can plot the factor scores.

pick <- paste0('factor[',match(pa11, dl$nameInfo$pa),',1]')
pi <- parInterval(fit3, pick, pa11, label='activity')
pi <- pi[order(pi$M),]
pi$activity <- factor(pi$activity, levels=pi$activity)

ggplot(pi) +
  geom_vline(xintercept=0, color="green") +
  geom_jitter(data=parDistributionFor(fit3, pi, samples=250),
              aes(value, activity), height = 0.35, alpha=.05) +
  geom_segment(aes(y=activity, yend=activity, x=L, xend=U),
               color="yellow", alpha=.5) +
  geom_point(aes(x=M, y=activity), color="red", size=1) +
  theme(axis.title.y=element_blank()) 

And there you have it. If you have not done so already, go find a dojo and commence study of martial arts!

Unidim Adapt

parameter	prior	purpose
threshold	normal(0,2)	item response thresholds
theta	normal(0,sigma)	latent score
sigma	lognormal(1,1)	latent score scale
scale	N/A	latent score scaling constant

The ‘unidim_adapt’ model has a varCorrection constant that is used to calibrate the scale. For all other models, per-item scale must be passed in as data. scale has no substantive interpretation, but it is used to partition signal between object variance and item discrimination. While object variance has no substantive interpretation, item discrimination is interpretable.

Unidim

parameter	prior	purpose
threshold	normal(0,2)	item response thresholds
alpha	exponential(0.1)	item discrimination
theta	normal(0,1)	latent score

Correlation

parameter	prior	purpose
threshold	normal(0,2)	item response thresholds
alpha	exponential(0.1)	item discrimination
thetaCor	lkj(2)	correlations between items
theta	see below	latent score

Thresholds for all items are combined into a single vector. The prior for theta is multivariate normal with correlations thetaCor and scale 1.0. Exclude rawTheta and rawThetaCorChol from sampling reports.

Factor

parameter	prior	purpose
threshold	normal(0,2)	item response thresholds
unique	normal(0,2)	scale of unique scores
uniqueTheta	normal(0,1)	unique scores
pathLoadings	normal(0,2)	signed scale of factor scores
factor	normal(0,1)	factor scores
pathProp	see below	signed factor variance proportion
Psi	see below	factor correlations
sigma	N/A	relative item scale

Thresholds for all items are combined into a single vector. pathProp is computed based on Equation 3 of Gelman et al. (in press). The prior on pathProp is normal(logit(0.5 + pathProp/2), pathScalePrior) where pathScalePrior is provided as data (see prepSingleFactorModel()). If you have more than one factor then Psi is available to estimate correlations among factors. Similar to pathScalePrior, the prior on entries of Psi is normal(logit(0.5 + Psi/2), psiScalePrior). The unique and pathLoadings parameters are only relatively interpretable because the scale is arbitrary. The most interpretable parameter is pathProp. pathProp is a signed proportion bounded between -1 and 1. Exclude rawUnique, rawUniqueTheta, rawFactor, rawLoadings, rawPerComponentVar, rawPathProp, rawNegateFactor, and rawSeenFactor from sampling. You may also like to exclude unique and uniqueTheta unless you have some special interest in the unique scores.

The idea of putting a prior on pathProp was inspired by Gelman (2019, Aug 23).