将向量分割成块，使得每个块的总和近似恒定

我有一个包含超过 100 000 条记录的大型数据框，其中的值已排序

例如，考虑以下虚拟数据集

df <- data.frame(values = c(1,1,2,2,3,4,5,6,6,7))

我想创建 3 组上述值（仅按顺序），以便每组的总和或多或少相同

所以对于上面的组，如果我决定划分排序的df分为以下 3 组，其总和为

1. 1 + 1 + 2 +2 + 3 + 4 = 13
2. 5 + 6 = 11
3. 6 + 7 = 13

如何在 R 中创建这种优化？有什么逻辑吗？

那么，让我们使用修剪。我认为其他解决方案提供了一个很好的解决方案，但不是最好的解决方案。

首先，我们要最小化

其中 S_n 是前 n 个元素的累积和。

computeD <- function(p, q, S) {
  n <- length(S)
  S.star <- S[n] / 3
  if (all(p < q)) {
    (S[p] - S.star)^2 + (S[q] - S[p] - S.star)^2 + (S[n] - S[q] - S.star)^2
  } else {
    stop("You shouldn't be here!")
  }
}

我认为其他解决方案独立地优化 p 和 q ，这不会给出全局最小值（预计在某些特定情况下）。

optiCut <- function(v) {
  S <- cumsum(v)
  n <- length(v)
  S_star <- S[n] / 3
  # good starting values
  p_star <- which.min((S - S_star)^2)
  q_star <- which.min((S - 2*S_star)^2)
  print(min <- computeD(p_star, q_star, S))
  
  count <- 0
  for (q in 2:(n-1)) {
    S3 <- S[n] - S[q] - S_star
    if (S3*S3 < min) {
      count <- count + 1
      D <- computeD(seq_len(q - 1), q, S)
      ind = which.min(D);
      if (D[ind] < min) {
        # Update optimal values
        p_star = ind;
        q_star = q;
        min = D[ind];
      }
    }
  }
  c(p_star, q_star, computeD(p_star, q_star, S), count)
}

这与其他解决方案一样快，因为它根据条件修剪了大量迭代S3*S3 < min。但是，它给出了最佳解决方案，请参阅optiCut(c(1, 2, 3, 3, 5, 10)).

对于 K >= 3 的解决方案，我基本上用嵌套的 tibbles 重新实现了树，这很有趣！

optiCut_K <- function(v, K) {
  
  S <- cumsum(v)
  n <- length(v)
  S_star <- S[n] / K
  # good starting values
  p_vec_first <- sapply(seq_len(K - 1), function(i) which.min((S - i*S_star)^2))
  min_first <- sum((diff(c(0, S[c(p_vec_first, n)])) - S_star)^2)
  
  compute_children <- function(level, ind, val) {
    
    # leaf
    if (level == 1) {
      val <- val + (S[ind] - S_star)^2
      if (val > min_first) {
        return(NULL)
      } else {
        return(val)
      } 
    } 
    
    P_all <- val + (S[ind] - S[seq_len(ind - 1)] - S_star)^2
    inds <- which(P_all < min_first)
    if (length(inds) == 0) return(NULL)
    
    node <- tibble::tibble(
      level = level - 1,
      ind = inds,
      val = P_all[inds]
    )
    node$children <- purrr::pmap(node, compute_children)
    
    node <- dplyr::filter(node, !purrr::map_lgl(children, is.null))
    `if`(nrow(node) == 0, NULL, node)
  }
  
  compute_children(K, n, 0)
}

这为您提供了比贪婪解决方案效果最差的所有解决方案：

v <- sort(sample(1:1000, 1e5, replace = TRUE))
test <- optiCut_K(v, 9)

你需要解除这个：

full_unnest <- function(tbl) {
  tmp <- try(tidyr::unnest(tbl), silent = TRUE)
  `if`(identical(class(tmp), "try-error"), tbl, full_unnest(tmp))
}
print(test <- full_unnest(test))

最后，为了获得最佳解决方案：

test[which.min(test$children), ]