Question

现在，我在学习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问题）？

Answer 1

约束后变量的标准方法是使用链接函数对其进行转换。这就是像Logistic回归和Poisson回归这样的广义线性模型（GLM）的工作方式。例如，要从不受约束的正值开始，我们使用对数变换。为了使（0，1）中的概率变为无约束，我们使用对数比值变换。

如果您的结果是1-10范围内的序数值，则尊重该数据范围的常见方法是ordinal logistic regression。

Answer 2

要扩展@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

再一次正确地限制了后部抽奖。

Stan模型后验预测超出了可能的数据范围

2 个答案:

方法1：有序逻辑回归

方法2：Beta回归