R语言分组计算百分位数报错：求函数适配修改方案

背景与现有代码 #

我用R做数据分析，现有数据集生成代码如下：

library(dplyr)

set.seed(123)
gender <- factor(sample(c("Male", "Female"), 5000, replace=TRUE, prob=c(0.45, 0.55)))
status <- factor(sample(c("Immigrant", "Citizen"), 5000, replace=TRUE, prob=c(0.3, 0.7)))
country <- factor(sample(c("A", "B", "C", "D"), 5000, replace=TRUE, prob=c(0.25, 0.25, 0.25, 0.25)))
disease <- factor(sample(c("Yes", "No"), 5000, replace=TRUE, prob=c(0.4, 0.6)))

my_data <- data.frame(gender, status, disease, country, var1 = rnorm(5000, 5000, 5000), var2 = rnorm(5000, 5000, 5000))

我写了一个计算任意百分位数的函数：

ptile <- function(x, n_percentiles) {
  # Calculate the percentiles
  pct <- quantile(x, probs = seq(0, 1, 1/n_percentiles))

  # Create a character vector to store the labels
  labels <- sprintf("%.2f to %.2f percentile %d",
                    head(pct, -1), tail(pct, -1), seq_len(n_percentiles))

  cut(x, breaks = pct, labels = labels, include.lowest = TRUE)
}

问题描述 #

在分组数据中调用该函数时（如下代码，当前示例数据集不报错，但其他数据集会触发）：

na.omit(my_data) %>%
    group_by(gender, status, country) %>%
    mutate(result1 = ptile(var1, 10), result2 = ptile(var2, 5))

会出现两种错误：

• Error in cut.default(x, breaks = pct, labels = labels, include.lowest = TRUE): invalid number of intervals
• Error in cut.default(x, breaks = pct, labels = labels, include.lowest = TRUE) : 'breaks' are not unique

我尝试过滤掉行数较少的分组，但报错依然存在：

na.omit(my_data) %>%
    group_by(gender, status, country) %>%
filter(n() >= 5) %>%
    mutate(result1 = ptile(var1, 10), result2 = ptile(var2, 5))

需求 #

希望修改ptile函数，使其在无法按指定层级计算百分位数时，自动使用最接近的可行层级：比如指定10分位数不可行时，改用当前分组能支持的最大分位数；若分组仅1条数据，则将其归入唯一分组。

解决方案：优化后的ptile函数 #

报错根源是分组内数据量不足、或存在大量重复值，导致quantile生成的断点重复，或指定的分位数数量超过了分组内唯一值的数量，cut无法处理。优化后的函数会自动调整分位数数量，确保计算有效：

ptile <- function(x, n_percentiles) {
  # 去除NA值
  x_clean <- na.omit(x)
  n <- length(x_clean)
  
  # 处理空数据或单条数据的情况
  if (n == 0) {
    return(rep(NA, length(x)))
  }
  if (n == 1) {
    return(factor(rep("Only observation", length(x))))
  }
  
  # 计算当前数据能支持的最大分位数（不超过指定值，且不超过唯一值数量）
  unique_vals <- length(unique(x_clean))
  max_possible <- min(n_percentiles, unique_vals)
  max_possible <- max(max_possible, 2)
  
  # 调整分位数数量，确保断点唯一
  target_p <- max_possible
  pct <- quantile(x_clean, probs = seq(0, 1, 1/target_p))
  pct_unique <- unique(pct)
  
  # 如果去重后断点数量不足，逐步降低分位数数量
  while (length(pct_unique) < target_p + 1) {
    target_p <- target_p - 1
    if (target_p < 2) break
    pct <- quantile(x_clean, probs = seq(0, 1, 1/target_p))
    pct_unique <- unique(pct)
  }
  
  # 生成对应标签
  if (length(pct_unique) == 2) {
    labels <- c(sprintf("%.2f to %.2f percentile 1", pct_unique[1], pct_unique[2]),
                sprintf("%.2f to %.2f percentile 2", pct_unique[1], pct_unique[2]))
  } else {
    labels <- sprintf("%.2f to %.2f percentile %d",
                      head(pct_unique, -1), tail(pct_unique, -1), seq_len(length(pct_unique)-1))
  }
  
  # 对原始x进行分组（保留NA值）
  cut(x, breaks = pct_unique, labels = labels, include.lowest = TRUE)
}

函数说明 #

1. 边界情况处理：空数据返回NA，单条数据直接标记为唯一分组
2. 自动调整分位数：根据分组内唯一值数量，将分位数限制在可行范围内，避免cut报错
3. 重复断点兼容：如果去重后断点仍不足，逐步降低分位数数量，直到生成有效分组
4. 原始数据兼容：保留原始数据的NA值，不对输入数据做额外修改

测试验证 #

可以用小分组数据测试：

# 模拟只有3条数据的分组
test_data <- data.frame(g = rep("A",3), val = c(1,1,2))
test_data %>%
  group_by(g) %>%
  mutate(ptile_val = ptile(val, 10))

输出会自动将分位数调整为2，生成有效分组。

内容的提问来源于stack exchange，提问作者stats_noob