关于R语言cut()函数性能优化的技术问询

当前cut.default函数的最后4行代码为：

code <- .bincode(x, breaks, right, include.lowest)
if (codes.only) 
  code
else factor(code, seq_along(labels), labels, ordered = ordered_result)

是否可以通过以下方式改写以实现性能优化？

code <- .bincode(x, breaks, right, include.lowest)
if (!codes.only) {
  levels(code) <- as.character(labels)
  class(code) <- c(if (ordered_result) "ordered" else character(0), "factor")
}
code

若该方案存在问题或并非合理优化方向，请说明原因。以下是针对该改写方案的性能测试结果，以及自定义实现的cut2函数：

小数据性能测试 #

library(bench)

x <- as.double(1:100) + 0
breaks <- seq(0, 90, 7)
unsorted_breaks <- sample(breaks)
mark(cut.default(x, breaks), 
            cut2(x, breaks), 
     min_iterations = 10^4)
# A tibble: 2 × 13
  expression       min median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc total_time result memory    
  <bch:expr>     <bch> <bch:>     <dbl> <bch:byt>    <dbl> <int> <dbl>   <bch:tm> <list> <list>    
1 cut.default(x… 130µs  148µs     6372.    2.97KB     1.27  9998     2      1.57s <fct>  <Rprofmem>
2 cut2(x, break… 101µs  115µs     8082.      448B     2.43  9997     3      1.24s <fct>  <Rprofmem>
# ℹ 2 more variables: time <list>, gc <list>

mark(cut.default(x, unsorted_breaks), 
            cut2(x, unsorted_breaks),
     min_iterations = 10^4)
# A tibble: 2 × 13
  expression       min median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc total_time result memory    
  <bch:expr>     <bch> <bch:>     <dbl> <bch:byt>    <dbl> <int> <dbl>   <bch:tm> <list> <list>    
1 cut.default(x… 130µs  148µs     6328.    2.97KB     1.90  9997     3      1.58s <fct>  <Rprofmem>
2 cut2(x, unsor… 106µs  116µs     8281.      448B     1.66  9998     2      1.21s <fct>  <Rprofmem>
# ℹ 2 more variables: time <list>, gc <list>

测试结论：小数据场景下，改写后的cut2比原生cut.default运行速度更快（每秒迭代次数提升约27%-31%），内存占用也大幅降低（从2.97KB降至448B），无论断点是否排序都有一致的优化效果。

大数据性能测试 #

set.seed(42)
x <- rnorm(10^6, 0, 10^5)
breaks <- seq(min(x), max(x), by = 5)

mark(cut.default(x, breaks),
            cut2(x, breaks))
# A tibble: 2 × 13
  expression       min median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc total_time result memory    
  <bch:expr>     <bch> <bch:>     <dbl> <bch:byt>    <dbl> <int> <dbl>   <bch:tm> <list> <list>    
1 cut.default(x… 1.78s  1.78s     0.561   113.9MB        0     1     0      1.78s <fct>  <Rprofmem>
2 cut2(x, break… 1.06s  1.06s     0.944    74.7MB        0     1     0      1.06s <fct>  <Rprofmem>
# ℹ 2 more variables: time <list>, gc <list>

x <- rnorm(10^7) + 0
b <- seq(0, max(x), 0.2) + 0

mark(e1 = cut.default(x, b),
     e2 = cut2(x, b))
# A tibble: 2 × 13
  expression      min   median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc total_time result
  <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl> <int> <dbl>   <bch:tm> <list>
1 e1            1.49s    1.49s     0.671     267MB    0.671     1     1      1.49s <fct> 
2 e2         282.39ms 303.67ms     3.29     38.1MB    0         2     0   607.34ms <fct> 
# ℹ 3 more variables: memory <list>, time <list>, gc <list>

测试结论：大数据场景下优化效果更显著：

• 100万条数据时，运行时间从1.78s缩短至1.06s，内存占用减少约34%；
• 1000万条数据时，运行时间从1.49s降至约0.3s（速度提升4倍以上），内存占用从267MB降至38.1MB，减少85%左右，还避免了一次垃圾回收（GC）。

自定义cut2函数实现 #

cut2 <- function (x, breaks, labels = NULL, include.lowest = FALSE, right = TRUE, 
                  dig.lab = 3L, ordered_result = FALSE, ...){
  if (!is.numeric(x)) 
    stop("'x' must be numeric")
  if (length(breaks) == 1L) {
    if (is.na(breaks) || breaks < 2L) 
      stop("invalid number of intervals")
    nb <- as.integer(breaks + 1)
    dx <- diff(rx <- range(x, na.rm = TRUE))
    if (dx == 0) {
      dx <- if (rx[1L] != 0) 
        abs(rx[1L])
      else 1
      breaks <- seq.int(rx[1L] - dx/1000, rx[2L] + dx/1000, 
                        length.out = nb)
    }
    else {
      breaks <- seq.int(rx[1L], rx[2L], length.out = nb)
      breaks[c(1L, nb)] <- c(rx[1L] - dx/1000, rx[2L] + 
                               dx/1000)
    }
  }
  else nb <- length(breaks <- sort.int(as.double(breaks)))
  if (anyDuplicated(breaks)) 
    stop("'breaks' are not unique")
  codes.only <- FALSE
  if (is.null(labels)) {
    for (dig in dig.lab:max(12L, dig.lab)) {
      ch.br <- formatC(0 + breaks, digits = dig, width = 1L)
      if (ok <- all(ch.br[-1L] != ch.br[-nb])) 
        break
    }
    labels <- if (ok) 
      paste0(if (right) 
        "("
        else "[", ch.br[-nb], ",", ch.br[-1L], if (right) 
          "]"
        else ")")
    else paste0("Range_", seq_len(nb - 1L))
    if (ok && include.lowest) {
      if (right) 
        substr(labels[1L], 1L, 1L) <- "["
      else substring(labels[nb - 1L], nchar(labels[nb - 
                                                     1L], "c")) <- "]"
    }
  }
  else if (is.logical(labels) && !labels) 
    codes.only <- TRUE
  else if (length(labels) != nb - 1L) 
    stop("number of intervals and length of 'labels' differ")
  code <- .bincode(x, breaks, right, include.lowest)
  if (!codes.only) {
    levels(code) <- as.character(labels)
    class(code) <- c(if (ordered_result) "ordered" else character(0), "factor")
  }
  code
}

改写方案的合理性分析 #

该改写方案的核心优化点在于：

• 原生cut.default通过factor()函数重新构造因子对象，会创建新的向量副本；而改写方案直接在.bincode返回的整数向量上修改levels和class属性，避免了数据复制，从而大幅降低内存占用并提升速度。
• 两种方案的输出结果完全一致：无论是因子的水平、排序属性（ordered_result参数），还是对NA值的处理，都和原生函数保持兼容。

潜在注意事项：

• 需要确保code向量的整数范围完全匹配labels的长度：由于.bincode返回的整数是1到nb-1（对应每个区间），而labels的长度正好是nb-1，因此levels(code) <- labels的赋值是安全的，不会出现水平不匹配的问题。
• 当ordered_result = TRUE时，通过class(code) <- c("ordered", "factor")设置类，和factor(ordered = TRUE)的效果完全一致，保证了有序因子的特性。

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