Stan模型后验预测超出了可能的数据范围
现在，我在学习Stan建模的绳索时非常开心。现在，我正在努力进行主题间和主题间混合析因实验设计的模型。有不同的主题组，每个主题表示他们期望三种不同饮料（水，无咖啡因和咖啡）中的每一种减少咖啡因摄入量的期望值。通过视觉模拟量表（0-10）测量结果变量-戒断期望值，其中0表示无戒断期望，10表示很高的戒断期望。我想测试三种不同饮料的预期减量-减少量之间是否存在组间差异。
这里是数据
df <- data.frame(id = rep(1:46, each = 3),
group = c(3,3,3,1,1,1,3,3,3,1,1,1,3,3,3,1,1,1,3,3,3,2,2,2,1,1,1,3,3,3,3,3,3,2,2,2,3,3,3,1,1,1,2,2,2,3,3,3,2,2,2,2,2,2,3,3,3,1,1,1,2,2,2,3,3,3,2,2,2,3,3,3,3,3,3,2,2,2,3,3,3,3,3,3,1,1,1,3,3,3,3,3,3,1,1,1,2,2,2,2,2,2,1,1,1,2,2,2,2,2,2,1,1,1,1,1,1,2,2,2,2,2,2,1,1,1,1,1,1,3,3,3,1,1,1,3,3,3),
bevType = rep(c(3,2,1), times = 46),
score = c(2.9,1.0,0.0,9.5,5.0,4.5,9.0,3.0,5.0,5.0,0.0,3.0,9.5,2.0,3.0,8.5,0.0,6.0,5.2,3.0,4.0,8.4,7.0,2.0,10.0,0.0,3.0,7.3,1.0,1.8,8.5,2.0,9.0,10.0,5.0,10.0,8.3,2.0,5.0,6.0,0.0,5.0,6.0,0.0,5.0,10.0,0.0,5.0,6.8,1.0,4.8,8.0,1.0,4.0,7.0,4.0,6.0,6.5,1.0,3.1,9.0,1.0,0.0,6.0,0.0,2.0,9.5,4.0,6.0,8.0,1.0,3.8,0.4,0.0,7.0,7.0,0.0,3.0,9.0,2.0,5.0,9.5,2.0,7.0,7.9,5.0,4.9,8.0,1.0,1.0,9.3,5.0,7.9,6.5,2.0,3.0,8.0,2.0,6.0,10.0,0.0,5.0,6.0,0.0,5.0,6.8,0.1,7.0,8.0,3.0,9.1,8.2,0.0,7.9,8.2,5.0,0.0,9.2,1.0,3.1,9.1,3.0,0.6,5.7,2.0,5.1,7.0,0.0,7.4,8.0,1.0,1.5,9.1,4.0,4.3,8.5,8.0,5.0))
现在为模型。该模型具有盛大均值参数a，代表从盛大均值bGroup出发的组偏差的分类预测变量，从盛中均值bBev到不同饮料类型的偏差的术语（{1}），以及每组饮料互动bSubj的术语。我还为每种饮料估计了单独的噪声参数。
为了进行后预测检查，我使用bGxB块和generated quantities函数从关节后部抽出了
normal_rng接下来，我们从关节后部提取抽奖，并生成95％HPDI上下均值的估计值。首先，我们需要一个函数来计算HPDI
### Step 1: Put data into list
dList <- list(N = 138,
nSubj = 46,
nGroup = 3,
nBev = 3,
sIndex = df$id,
gIndex = df$group,
bIndex = df$bevType,
score = df$score,
gMean = 4.718841,
gSD = 3.17)
#### Step 1 model
write("
data{
int<lower=1> N;
int<lower=1> nSubj;
int<lower=1> nGroup;
int<lower=1> nBev;
int<lower=1,upper=nSubj> sIndex[N];
int<lower=1,upper=nGroup> gIndex[N];
int<lower=1,upper=nBev> bIndex[N];
real score[N];
real gMean;
real gSD;
}
parameters{
real a;
vector[nSubj] bSubj;
vector[nGroup] bGroup;
vector[nBev] bBev;
vector[nBev] bGxB[nGroup]; // vector of vectors, stan no good with matrix
vector[nBev] sigma;
real<lower=0> sigma_a;
real<lower=0> sigma_s;
real<lower=0> sigma_g;
real<lower=0> sigma_b;
real<lower=0> sigma_gb;
}
model{
vector[N] mu;
//hyper-priors
sigma_s ~ normal(0,10);
sigma_g ~ normal(0,10);
sigma_b ~ normal(0,10);
sigma_gb ~ normal(0,10);
//priors
sigma ~ cauchy(0,1);
a ~ normal(gMean, gSD);
bSubj ~ normal(0, sigma_s);
bGroup ~ normal(0,sigma_g);
bBev ~ normal(0,sigma_b);
for (i in 1:nGroup) { //hierarchical prior on interaction
bGxB[i] ~ normal(0, sigma_gb);
}
// likelihood
for (i in 1:N){
score[i] ~ normal(a + bGroup[gIndex[i]] + bBev[bIndex[i]] + bSubj[sIndex[i]] + bGxB[gIndex[i]][bIndex[i]], sigma[bIndex[i]]);
}
}
generated quantities{
real y_draw[N];
for (i in 1:N) {
y_draw[i] = normal_rng(a + bGroup[gIndex[i]] + bBev[bIndex[i]] + bSubj[sIndex[i]] + bGxB[gIndex[i]][bIndex[i]], sigma[bIndex[i]]);
}
}
", file = "temp.stan")
##### Step 3: generate the chains
mod <- stan(file = "temp.stan",
data = dList,
iter = 5000,
warmup = 3000,
cores = 1,
chains = 1)
现在从后部提取抽奖
HPDIFunct <- function (vector) {
sortVec <- sort(vector)
ninetyFiveVec <- ceiling(.95*length(sortVec))
fiveVec <- length(sortVec) - length(ninetyFiveVec)
diffVec <- sapply(1:fiveVec, function (i) sortVec[i + ninetyFiveVec] - sortVec[i])
minVal <- sortVec[which.min(diffVec)]
maxVal <- sortVec[which.min(diffVec) + ninetyFiveVec]
return(list(sortVec, minVal, maxVal))
}
从图表上可以看出，对于水的期望值，模型似乎很好地表示了数据的中心（十字）和分布（空心圆）。但是，这对于零咖啡因和咖啡的期望值却有所下降。对于Decaf期望值，较低的HPDI低于可能的值范围（下限= 0），并且从后部开始的拉伸分布（在每个组中以空心圆表示）太大。 Coffee组的HPDI上限也高于数据范围（上限= 10），并且散布对于实际数据而言太大。
所以我的问题是：
如何将从关节后部开始的抽签限制在数据的实际范围内？
在Stan中是否存在某种蛮力方法来限制后方的平局？还是对三种饮料条件下方差的差异进行更自适应的估计会更有效（在这种情况下，这更像是CV问题而不是SO问题）？
2 个答案:
答案 0 :(得分：3)
约束后变量的标准方法是使用链接函数对其进行转换。这就是像Logistic回归和Poisson回归这样的广义线性模型（GLM）的工作方式。例如，要从不受约束的正值开始，我们使用对数变换。为了使（0，1）中的概率变为无约束，我们使用对数比值变换。
如果您的结果是1-10范围内的序数值，则尊重该数据范围的常见方法是ordinal logistic regression。
答案 1 :(得分：1)
要扩展@Bob Carpenter的答案，可以采用以下两种方法来解决此问题。 （我最近有理由同时使用这两种方法，并且努力使它们启动并运行。这可能对像我这样的其他初学者很有用。）
方法1：有序逻辑回归
我们将假设每个用户对每个响应都具有“真实的”期望值，该期望值在任意连续范围内，并将其建模为潜在变量。如果用户的实际响应属于K类别，我们还将在这些类别之间的K - 1切点建模。用户选择给定响应类别的概率等于相关切入点之间logistic pdf下的面积。
Stan模型如下所示。主要区别在于模型适合cutpoints的附加有序向量，并使用ordered_logistic分布。 （我也将sigma上的先验更改为Cauchy，以使其保持肯定，并切换到non-centered parameterization。但是这些更改与手头的问题无关。）
data {
int<lower=1> N;
int<lower=1> nSubj;
int<lower=1> nGroup;
int<lower=1> nBev;
int minResponse;
int maxResponse;
int<lower=1,upper=nSubj> sIndex[N];
int<lower=1,upper=nGroup> gIndex[N];
int<lower=1,upper=nBev> bIndex[N];
int<lower=minResponse,upper=maxResponse> score[N];
}
parameters {
real a;
vector[nSubj] bSubj;
vector[nGroup] bGroup;
vector[nBev] bBev;
vector[nBev] bGxB[nGroup];
real<lower=0> sigma_s;
real<lower=0> sigma_g;
real<lower=0> sigma_b;
real<lower=0> sigma_gb;
ordered[maxResponse - minResponse] cutpoints;
}
model {
//hyper-priors
sigma_s ~ cauchy(0, 1);
sigma_g ~ cauchy(0, 1);
sigma_b ~ cauchy(0, 1);
sigma_gb ~ cauchy(0, 1);
//priors
a ~ std_normal();
bSubj ~ std_normal();
bGroup ~ std_normal();
bBev ~ std_normal();
for (i in 1:nGroup) {
bGxB[i] ~ std_normal();
}
// likelihood
for(i in 1:N) {
score[i] ~ ordered_logistic(a +
(bGroup[gIndex[i]] * sigma_g) +
(bBev[bIndex[i]] * sigma_b) +
(bSubj[sIndex[i]] * sigma_s) +
(bGxB[gIndex[i]][bIndex[i]] * sigma_gb),
cutpoints);
}
}
generated quantities {
real y_draw[N];
for (i in 1:N) {
y_draw[i] = ordered_logistic_rng(a +
(bGroup[gIndex[i]] * sigma_g) +
(bBev[bIndex[i]] * sigma_b) +
(bSubj[sIndex[i]] * sigma_s) +
(bGxB[gIndex[i]][bIndex[i]] * sigma_gb),
cutpoints);
}
}
看起来您的数据集中的响应记录到最接近的十分之一，因此，我们可以在0到10之间找到101种可能的类别。要使所有内容都成为Stan友好的整数，我们可以将所有响应乘以10。（我也在每个响应中添加一个，因为当可能类别之一为零时，我无法拟合模型。）
dList <- list(N = 138,
nSubj = 46,
nGroup = 3,
nBev = 3,
minResponse = 1,
maxResponse = 101,
sIndex = df$id,
gIndex = df$group,
bIndex = df$bevType,
score = (df$score * 10) + 1)
提取y_draw之后，可以将其转换回原始比例：
y_draw <- (data.frame(extract(mod, pars = "y_draw")) - 1) / 10
其他所有内容与以前相同。现在，后验预测已正确地限制在[0, 10]中。
方法2：Beta回归
一旦我们获得101个响应类别，将这些可能性称为离散类别似乎有点奇怪。就像您的原始模型尝试做的那样，说我们正在捕获连续的结果（恰好在0到10之间）是很自然的。而且，在有序逻辑回归中，响应类别不必是有规律的相对于潜在变量隔开。 （这是一个功能，而不是错误；例如，对于Likert响应，不能保证“完全同意”和“同意”之间的区别与“同意”和“都不同意不反对”之间的区别是相同的。 ），因此，很难说出某个特定因素导致响应以原始范围（而不是潜在变量的范围）移动的“距离”。但是上面的模型推断出的割点间隔相当规则，这再次表明您的数据集中的结果已经具有合理的鳞片状：
# Get the sampled parameters
sampled.params.df = data.frame(as.array(mod)[,1,]) %>%
select(-matches("y_draw")) %>%
rownames_to_column("iteration")
# Plot selected cutpoints
sampled.params.df %>%
select(matches("cutpoints")) %>%
gather(cutpoint, value) %>%
mutate(cutpoint.num = as.numeric(gsub("^cutpoints\\.([0-9]+)\\.$", "\\1", cutpoint))) %>%
group_by(cutpoint.num) %>%
summarize(mean.value = mean(value),
lower.95 = quantile(value, 0.025),
lower.50 = quantile(value, 0.25),
upper.50 = quantile(value, 0.75),
upper.95 = quantile(value, .975)) %>%
ggplot(aes(x = cutpoint.num, y = mean.value)) +
geom_point(size = 3) +
geom_linerange(aes(ymin = lower.95, ymax = upper.95)) +
geom_linerange(aes(ymin = lower.50, ymax = upper.50), size = 2) +
scale_x_continuous("cutpoint", breaks = seq(0, 100, 10)) +
scale_y_continuous("") +
theme_bw()
（粗线和细线分别代表50％和95％的间隔。我享受每10个切入点的小“跳跃”，这表明受试者将5.9与6.0的差异视为与5.8与5.8的差异更大。 5.9。但是效果似乎很温和，音阶也似乎向高端延伸了一点，但又不过分了。）
对于有限区间内的连续结果，我们可以使用beta distribution;请参阅here和here进行进一步的讨论。
对于beta分布，我们需要两个参数mu和phi，两个参数都必须为正。在这个例子中，我允许mu不受限制并应用inv_logit，然后再将其输入Beta发行版；我限制phi为肯定，并事先给了柯西（Cauchy）。但是您可以通过多种方式来实现。我还编码了全套mu参数，但只编码了一个phi；再一次，您可以尝试其他选项。
data {
int<lower=1> N;
int<lower=1> nSubj;
int<lower=1> nGroup;
int<lower=1> nBev;
int<lower=1,upper=nSubj> sIndex[N];
int<lower=1,upper=nGroup> gIndex[N];
int<lower=1,upper=nBev> bIndex[N];
vector<lower=0,upper=1>[N] score;
}
parameters {
real a;
real a_phi;
vector[nSubj] bSubj;
vector[nGroup] bGroup;
vector[nBev] bBev;
vector[nBev] bGxB[nGroup];
real<lower=0> sigma_s;
real<lower=0> sigma_g;
real<lower=0> sigma_b;
real<lower=0> sigma_gb;
}
model {
vector[N] mu;
//hyper-priors
sigma_s ~ cauchy(0, 1);
sigma_g ~ cauchy(0, 1);
sigma_b ~ cauchy(0, 1);
sigma_gb ~ cauchy(0, 1);
//priors
a ~ std_normal();
a_phi ~ cauchy(0, 1);
bSubj ~ std_normal();
bGroup ~ std_normal();
bBev ~ std_normal();
for (i in 1:nGroup) {
bGxB[i] ~ std_normal();
}
// likelihood
for(i in 1:N) {
mu[i] = a +
(bGroup[gIndex[i]] * sigma_g) +
(bBev[bIndex[i]] * sigma_b) +
(bSubj[sIndex[i]] * sigma_s) +
(bGxB[gIndex[i]][bIndex[i]] * sigma_gb);
score[i] ~ beta(inv_logit(mu[i]) .* a_phi,
(1 - inv_logit(mu[i])) .* a_phi);
}
}
generated quantities {
real y_draw[N];
real temp_mu;
for (i in 1:N) {
temp_mu = a +
(bGroup[gIndex[i]] * sigma_g) +
(bBev[bIndex[i]] * sigma_b) +
(bSubj[sIndex[i]] * sigma_s) +
(bGxB[gIndex[i]][bIndex[i]] * sigma_gb);
y_draw[i] = beta_rng(inv_logit(temp_mu) .* a_phi,
(1 - inv_logit(temp_mu)) .* a_phi);
}
}
(0, 1)支持beta分布，因此我们将观察到的分数除以10。（如果模型给出的分数恰好为0或1，该模型也会失败，因此我将所有此类分数均转换为0.01和0.99分别。）
dList.beta <- list(N = 138,
nSubj = 46,
nGroup = 3,
nBev = 3,
sIndex = df$id,
gIndex = df$group,
bIndex = df$bevType,
score = ifelse(df$score == 0, 0.01,
ifelse(df$score == 10, 0.99,
df$score / 10)))
提取y_draw时撤消转换，然后过程与以前相同。
y_draw.beta <- data.frame(extract(mod.beta, pars = "y_draw")) * 10
再一次正确地限制了后部抽奖。
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？