如何基于分位数调整R语言中z-score的计分逻辑？

我有一份约1000行的数据，结构如下：

head(data)

   alt   alb   alp alt_zscore alb_zscore alp_zscore
 <dbl> <dbl> <dbl>      <dbl>      <dbl>      <dbl>
1  11    2.60   9       -1.54      -7.82      -0.949
2  12    5.37  86.3     -1.45      -0.351      2.31 
3  15.7  4.67  28       -1.09      -2.24      -0.148
4   7    4.43 171.      -1.93      -2.89       5.87 
5  14.5  3.75  12       -1.20      -4.72      -0.822
6  17.5  3.70  82.5     -0.915     -4.86       2.15

每个变量列（如alt、alb、alp）都有对应的z-score列（alt_zscore、alb_zscore、alp_zscore）。

此前我用以下R代码，针对每个z-score列，若观测值低于均值1个标准差，则取该z-score的绝对值，否则赋值为0；随后将符合条件的z-score求和生成total_score列：

name <- c("alt_zscore", "alb_zscore", "alp_zscore")

stdev <- 1

lf <- list(
  \(x) ifelse(x <= -stdev, abs(x), 0),
  \(x) ifelse(x <= -stdev, abs(x), 0),
  \(x) ifelse(x <= -stdev, abs(x), 0)
) %>% 
  setNames(name)

data <- data %>% 
  mutate(total_score = rowSums(across(all_of(name), ~ lf[[cur_column()]](.)), na.rm = TRUE))

现在需要修改代码，实现：

• 针对每个常规列（如alt），若观测值小于该列的25th percentile（25分位数），则取对应z-score列的绝对值，否则赋值为0；
• 同时代码要支持调整为判断75th percentile，或同时判断25th和75th percentile的场景。

1. 判断低于25分位数的场景 #

先定义常规变量与对应z-score列的映射，计算各列25分位数后，通过across批量处理逻辑：

# 定义常规变量列和对应的z-score列
var_names <- c("alt", "alb", "alp")

# 计算各常规列的25分位数
pct25 <- data %>% summarize(across(all_of(var_names), ~ quantile(., probs = 0.25, na.rm = TRUE)))

# 生成total_score
data <- data %>%
  mutate(
    # 对每个常规列，判断是否小于25分位数，对应取z-score绝对值或0
    across(all_of(var_names), 
           ~ ifelse(.x < pct25[[cur_column()]], abs(get(paste0(cur_column(), "_zscore"))), 0),
           .names = "{.col}_contribution"),
    # 求和所有贡献列得到total_score
    total_score = rowSums(across(ends_with("_contribution")), na.rm = TRUE)
  ) %>%
  # 可选：删除中间贡献列
  select(-ends_with("_contribution"))

2. 判断高于75分位数的场景 #

仅需调整分位数取值和判断条件：

# 计算各常规列的75分位数
pct75 <- data %>% summarize(across(all_of(var_names), ~ quantile(., probs = 0.75, na.rm = TRUE)))

data <- data %>%
  mutate(
    across(all_of(var_names), 
           ~ ifelse(.x > pct75[[cur_column()]], abs(get(paste0(cur_column(), "_zscore"))), 0),
           .names = "{.col}_contribution"),
    total_score = rowSums(across(ends_with("_contribution")), na.rm = TRUE)
  ) %>%
  select(-ends_with("_contribution"))

3. 同时判断低于25分位数或高于75分位数的场景 #

调整判断逻辑为满足任一条件即取z-score绝对值：

# 计算各常规列的25和75分位数
pcts <- data %>% summarize(across(all_of(var_names), ~ list(q25 = quantile(., 0.25, na.rm=TRUE), q75 = quantile(., 0.75, na.rm=TRUE))))

data <- data %>%
  mutate(
    across(all_of(var_names), 
           ~ ifelse(.x < pcts[[cur_column()]]$q25 | .x > pcts[[cur_column()]]$q75, 
                   abs(get(paste0(cur_column(), "_zscore"))), 0),
           .names = "{.col}_contribution"),
    total_score = rowSums(across(ends_with("_contribution")), na.rm = TRUE)
  ) %>%
  select(-ends_with("_contribution"))

通用封装函数（可选） #

如果需要频繁切换判断逻辑，可封装为复用函数：

calculate_total_score <- function(data, var_names, threshold_type = c("q25", "q75", "both")) {
  threshold_type <- match.arg(threshold_type)
  
  # 计算对应分位数并定义判断逻辑
  if (threshold_type == "q25") {
    pcts <- data %>% summarize(across(all_of(var_names), ~ quantile(., 0.25, na.rm = TRUE)))
    cond_fun <- function(x, col) x < pcts[[col]]
  } else if (threshold_type == "q75") {
    pcts <- data %>% summarize(across(all_of(var_names), ~ quantile(., 0.75, na.rm = TRUE)))
    cond_fun <- function(x, col) x > pcts[[col]]
  } else {
    pcts <- data %>% summarize(across(all_of(var_names), ~ list(q25 = quantile(., 0.25, na.rm=TRUE), q75 = quantile(., 0.75, na.rm=TRUE))))
    cond_fun <- function(x, col) x < pcts[[col]]$q25 | x > pcts[[col]]$q75
  }
  
  # 生成total_score
  data %>%
    mutate(
      across(all_of(var_names), 
             ~ ifelse(cond_fun(.x, cur_column()), abs(get(paste0(cur_column(), "_zscore"))), 0),
             .names = "{.col}_contribution"),
      total_score = rowSums(across(ends_with("_contribution")), na.rm = TRUE)
    ) %>%
    select(-ends_with("_contribution"))
}

# 使用示例
data <- calculate_total_score(data, var_names = c("alt", "alb", "alp"), threshold_type = "q25")
data <- calculate_total_score(data, var_names = c("alt", "alb", "alp"), threshold_type = "q75")
data <- calculate_total_score(data, var_names = c("alt", "alb", "alp"), threshold_type = "both")

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