在 R 中分配分位数，其中分位数不是唯一的

Question

让x 是一个由数字、非负数据（大多数 qx <- quantile(x, probs = pq) 组成的向量，其中length(pq) 通常是 > length(x) * (3/4)。 我需要qx 的索引向量，称之为q_i，其中x[i] 属于分位数qx[q_i[i]]。

如标题所示，问题在于qx 中可能存在非唯一值，例如如果x 是零膨胀的，则为多个 0 值分位数，并且可能还有其他重复值。我想通过（a）回收这些等效分位数的索引序列或（b）随机分配等效分位数的索引来处理这些情况。我想我更喜欢选项 (a)，但任何一个的解决方案都会很有用。

下面是一个编辑，提供了为特定x[i] 确定q_i[i] 的规则： 考虑qx 有一个或多个重复值序列，即对于某些j 有（是）序列qx[j:n] 其中qx[j] == qx[j + 1] == ... == qx[j + n] < qx[j + n + 1]。让k = c(j, j + 1,..., j + n)。然后q_i[i] <- k[r] where qx[j] <= x[i] <= qx[j + n + 1] if j == 1 or qx[j] < x[i] <= qx[j + n + 1] if j > 1, and where r <- m %% (n + 1) 这样x[i] 是m-th 出现在x 中的不等式已经得到满足。

注意：根据这条规则，我意识到我在原来的 q_i 中省略了 4 - 这已被更改。

注意：@hodgenovice 提出了一个很好的观点，即严格小于两个分位数的数据值可能被分组到两个这样的分位数之间的“bin”中。我并不特别关心这种特殊情况，因为例如，如果没有重复的分位数但我们有相同的分位数，那么这些特殊情况会被正确地合并在一起。

我认为有一种有效的方法可以做到这一点 - 我基本上是使用 for 循环完成的，但我正在寻找一种矢量化方法。

我开始尝试使用 cut() ，这当然不允许非唯一中断。我发现 this question here 有帮助，因为我发现了 .bincode() 函数，它确实允许非唯一中断。但是，它没有“分配”索引的规则 - 它只会使用每个重复分位数值中第一个的索引。

这个问题的一些示例代码：

x <- c(5.8,  0.0, 16.1,  5.8,  3.5, 13.8,  6.9,  5.8, 11.5,  9.2, 11.5,
       3.5,  0.0,  8.1,  0.0,  4.6,  5.8,  3.5,  0.0, 10.3,  0.0,  0.0,
       3.5, 6.9, 3.5)
pq <- seq(0, 1, length.out = 20)
qx <- quantile(x, pq)

# quantiles for reference, rounded for readability
round(as.numeric(qx), 2)
[1]  0.00  0.00  0.00  0.00  0.18  3.50  3.50  3.50  3.62  5.04  5.80 5.80  5.97
[14] 6.90  7.72  9.14 10.55 11.50 13.19 16.10

q_i <- .bincode(x, qx, include.lowest = TRUE)
q_i
[1] 10  1 19 10  5 19 13 10 17 16 17  5  1 15  1  9 10  5  1 16  1  1  5 13 5

如果.bincode() 很神奇，我可以说服它去做我需要的事情，那么这是我要寻找的结果：

在上述情况（a）下： （我也编辑了这个，因为我最初缺少 4 的值）

q_i
[1] 10 1 19 11 5 19 13 10 17 16 17 6 2 15 3 9 11 7 4 16 1 2 5 13 6

在场景 (b) 下，它可能看起来与上面相同。或者类似的东西：

q_i
[1] 10 1 19 10 6 19 13 11 17 16 17 5 3 15 2 9 11 6 2 16 1 4 5 13 7

请注意，被回收的“等效”qx 序列的完整向量基本上是在没有替换的情况下进行采样的。

谢谢！

Answer 1

好的，我有一些代码可以从你的代码继续到场景 a（回收）下的最终 q_i。我希望它更漂亮一点，但无论如何希望它有所帮助。

注意：
- 这假设length(x) > length(qx) > length(x)/2。
- 在代码下方的解释中，q_i 指的是问题末尾的值，在任何回收或替换值发生之前。

## Start off with the code provided in the question...
#  1. For each distinct q_i, calculate the number of occurrances, and how far we can recycle it
df <- data.frame(lower=sort(unique(q_i)), freq=as.integer(table(q_i)))
df$upper <- c(df$lower[-1] - df$lower[-nrow(df)], 1) + df$lower - 1
df$upper <- df$upper - as.numeric(df$upper > df$lower & qx[df$upper] < qx[df$upper + 1])

#  2. Identify when there's a (single) number we can't recycle, and identify which position it's in
#     e.g. is it the third time q_i == 10?
df$special_case <- rep(NA, nrow(df))
df$special_case[df$lower < df$upper] <- sapply(df$lower[df$lower < df$upper], function(low) {
                                        bin <- x[q_i==low]
                                        if(length(unique(bin)) > 1) {
                                          return(match(min(bin), bin))} 
                                        else return(NA)})

# 3. For each row of df, get a vector of (possibly recycled) numbers
recycled <- apply(df, 1, function(x) {
  out <- rep(x["lower"]:x["upper"], length.out=x["freq"])

  # This part modifies the vector created to handle the 'special case'
  if(!is.na(x["special_case"])) {
    out[x["special_case"]] <- x["lower"]
    if(x["special_case"] < x["freq"]) {
      out[(x["special_case"]+1):x["freq"]] <- out[x["special_case"]:(x["freq"]-1)]
    }
  }
  return(out)
})

# 3b. Make this follow the same order as q_i
q_i_final <- unlist(recycled)[order(order(q_i))]

q_i_final
[1] 10  1 19 11  5 19 13 10 17 16 17  6  2 15  3  9 11  7  1 16  2  3  5 13  6

基本思想是什么？
对于q_i 的每个值，我们可以相当容易地计算出我们应该回收的数量（如果我们应该回收的话）。我们通常可以回收比q_i 的下一个最大值少一个。然后我们可以使用rep 创建一个回收向量来替换q_i 中的内容，例如将四个10s 替换为10 11 10 11。

还有什么需要考虑的？
这个基本思想假设对于q_i 的每个值，x 的相应值可以全部回收或不全部回收。这是通常的情况，但你也可以有一些q_i的值，其中all bar one可以被回收，即一个k使得x[k] qx[q_i[k]+1] , 但一个或多个 j 其中 q_i[j] = q_i[k] 和 x[j] = qx[q_i[j]+1]。

应识别此类“特殊”情况（尽管问题数据中不存在），并且必须注意不要同时回收此值。

---

更详细的特殊情况

1. 我们可以对问题数据进行一些简单的更改来创建这个案例（参见下面的代码）。注意x[5] > x[12]，但q_i[5] = q_i[12] = 4。现在，根据上述“基本思想”，q_i = 4 的所有值都将被回收，因此我们将有 q_i_final[12] = 5。这是一个问题，因为我们希望x[12] 介于qx[q_i_final[12]] 和qx[q_i_final[12]+1] 之间，但事实并非如此，因为它严格小于两者。事实证明，我们可以回收 q_i = 4 的所有值，x[12] 除外。

新代码：

# Code copied from question, changes as follows:
# x[12] changed from 3.5 to 3.4
# x[13] and x[21] changed from 0.0 to 10.0
x <- c(5.8,  0.0, 16.1,  5.8,  3.5, 13.8,  6.9,  5.8, 11.5,  9.2, 11.5,
       3.4,  10.0,  8.1,  0.0,  4.6,  5.8,  3.5,  0.0, 10.3,  10.0,  0.0,
       3.5, 6.9, 3.5)
pq <- seq(0, 1, length.out = 20)
qx <- quantile(x, pq)
q_i <- .bincode(x, qx, include.lowest = T, right=T)

q_i
[1]  8  1 19  8  4 19 12  8 17 14 17  4 15 13  1  8  8  4  1 16 15  1  4 12  4

Answer 2

此代码基于@hodgenovice 的回答，但未考虑特殊情况。

它有一个附加条件可以正确回收第一个重复分位数序列的值。这是我在问题中的一个错误，我最初从我想要的答案中省略了 q_i 的 4 ，但它应该是为由 @ 分配了 1 的 q_i 的数据值回收的索引之一987654325@.

df <- data.frame(lower=sort(unique(q_i)), freq=as.integer(table(q_i)))
df$upper <- c(df$lower[-1] - df$lower[-nrow(df)], 1) + df$lower - 1
# want to omit this adjustment if the first quantile is also the first
#   duplicate, to follow rule described in question edit
ub <- df$lower != 1
df$upper[ub] <- df$upper[ub] - as.numeric(df$upper[ub] > df$lower[ub] & 
                  qx[df$upper[ub]] < qx[df$upper[ub] + 1])

recycled <- apply(df, 1, function(x) {
  out <- rep(x["lower"]:x["upper"], length.out=x["freq"])

  return(out)
})

q_i_final <- unlist(recycled)[order(order(q_i))]