Question

有没有人对如何提高以下代码示例的效率有任何想法或建议，这些代码使用＆＃34;种类的＆＃34;双滚窗？

首先，我将通过一个简单的示例来定义问题，在本文的底部有一个完整的MWE（实现）。

首先，考虑以下＆＃34;随机＆＃34;测试载体（通常长度> 25000）：

A <- c(1.23,5.44,6.3,8.45,NaN,3.663,2.63,1.32,6.623,234.6,252.36)

A被划分为＆＃34;种类＆＃34;火车和测试装置，都有滚动的窗户。在该MWE中，考虑长度4的列车开始和2的测试集长度（通常长度> 200）。因此，最初，以下值是列车和测试集的一部分：

train_1 <- A[1:4]
test_1 <- A[5:6]

接下来，我想在test_1的每个可能的连续位置（因此是第一个滚动窗口）从train_1中减去train_1，生成run_1_sub矩阵。

run_1_sub <- matrix(NaN,3,2)
run_1_sub[1,] <- train_1[1:2] - test_1
run_1_sub[2,] <- train_1[2:3] - test_1
run_1_sub[3,] <- train_1[3:4] - test_1

之后，我想在run_1_sub的每一行中找到每行的总和除以每行中不是NaN的条目数。

run_1_sum <-
    sapply(1:3, function(x) {
       sum(run_1_sub[x,], na.rm = T) / sum(!is.na(run_1_sub[x,]))
})

在下一步中，＆＃34;种类＆＃34;通过将它们的顺序从A增加一个（因此是第二个滚动窗口）来更新列车和测试集：

train_2 <- A[2:5] 
test_2 <- A[6:7]

如前所述，test_2中的每个可能位置都会减去train_2，并计算run_2_sub和run_2_sum。这个过程一直持续到测试集代表A的最后两个值，最后我用6个run_sum矩阵结束（在这个MWE中）。然而，我的实施非常缓慢，我想知道是否有人可以帮助我提高它的效率？

这是我的实施：

# Initialization
library(zoo) 
#rm(list = ls())
A <- c(1.23, 5.44, 6.3, 8.45, NaN, 3.663, 2.63, 1.32, 6.623, 234.6, 252.36) # test vector
train.length <- 4
test.length <- 2
run.length <- length(A) - train.length - test.length + 1
# Form test sets
test.sets <- sapply(1:run.length, function(x) {
A[(train.length + x):(train.length + test.length + x - 1)]
})
# Generate run_sub_matrices
run_matrix <- lapply(1:run.length, function(x) {
    rollapply(A[x:(train.length + x - 1)], width = test.length, by = 1,
        function(y) {
            y - test.sets[, x]
            })
})
# Genereate run_sum_matrices
run_sum <- sapply(1:length(run_matrix), function(x) {
rowSums(run_matrix[[x]], na.rm = T) / apply(run_matrix[[x]], 1,  function(y) {
sum(!is.na(y))})
})

当然，以下初始化设置会显着降低run_sum和run_sub的生成速度：

A <- runif(25000)*400
train.length <- 400
test.length <- 200

此处，生成run_sub所用的时间分别为120.04s和run_sum 28.69s。

有关如何提高和提高速度和代码的任何建议吗？

Answer 1

通常，R中代码优化的前两步是：

少做;
使用矢量化。

我们将完成这两个步骤。我们同意将x视为输入向量（在您的示例中为A）。

您问题中的关键功能单元可以表述如下：给定train_start（train子集的起始索引。我们将使用单词＆＃39; train＆＃39; for this subset），test_start（test的起始索引）和test_length（test的长度）计算：

train_inds <- train_start + 0:(test_length-1)
test_inds <- test_start + 0:(test_length-1)
run_diff <- x[train_inds] - x[test_inds]
sum(run_diff, na.rm = TRUE) / sum(!is.na(run_diff))

这个单位被多次调用，因此计算总和和!is.na。我们将做得更少：我们预先计算累积总和并使用此数据，而不是计算与其总和的多次差异。参见＆＃39;准备计算＆＃39;在run_mean_diff。

res现在包含x_mod的所需差异总和（x的副本，但是代替NA和NaN s的0 。我们现在应该减去所有过度使用的元素，即那些我们不应该在和中使用的元素，因为其他集合中的相应元素是NA或NaN。在计算此信息时，我们还将计算分母。请参阅有关额外元素的信息＆＃39;在run_mean_diff。

此代码的优点在于train_start，test_start和test_length现在可以是向量：i每个向量的元素都被视为我们任务的单个元素。这是矢量化。我们现在的工作是构建适合我们任务的这些载体。请参阅函数generate_run_data。

提供的代码使用的内存少得多，不需要额外的zoo依赖，并且在小train_length和test_length上的原始代码要快得多。在大*_length上也更快但不是很多。

接下来的步骤之一可能是使用Rcpp编写此代码。

代码：

run_mean_diff <- function(x, train_start, test_start, test_length) {
  # Preparatory computations
  x_isna <- is.na(x)
  x_mod <- ifelse(x_isna, 0, x)
  x_cumsum <- c(0, cumsum(x_mod))

  res <- x_cumsum[train_start + test_length] - x_cumsum[train_start] -
    (x_cumsum[test_start + test_length] - x_cumsum[test_start])

  # Info about extra elements
  extra <- mapply(
    function(cur_train_start, cur_test_start, cur_test_length) {
      train_inds <- cur_train_start + 0:(cur_test_length-1)
      test_inds <- cur_test_start + 0:(cur_test_length-1)

      train_isna <- x_isna[train_inds]
      test_isna <- x_isna[test_inds]

      c(
        # Correction for extra elements
        sum(x_mod[train_inds][test_isna]) -
              sum(x_mod[test_inds][train_isna]),
        # Number of extra elements
        sum(train_isna | test_isna)
      )
    },
    train_start, test_start, test_length, SIMPLIFY = TRUE
  )

  (res - extra[1, ]) / (test_length - extra[2, ])
}

generate_run_data <- function(n, train_length, test_length) {
  run_length <- n - train_length - test_length + 1
  num_per_run <- train_length - test_length + 1

  train_start <- rep(1:num_per_run, run_length) +
    rep(0:(run_length - 1), each = num_per_run)
  test_start <- rep((train_length + 1):(n - test_length + 1),
                    each = num_per_run)

  data.frame(train_start = train_start,
             test_start = test_start,
             test_length = rep(test_length, length(train_start)))
}

A <- c(1.23, 5.44, 6.3, 8.45, NaN, 3.663,
       2.63, 1.32, 6.623, 234.6, 252.36)
train_length <- 4
test_length <- 2
run_data <- generate_run_data(length(A), train_length, test_length)

run_sum_new <- matrix(
  run_mean_diff(A, run_data$train_start, run_data$test_start,
                run_data$test_length),
  nrow = train_length - test_length + 1
)

Answer 2

你的代码使用如此多RAM的原因是你保留了很多中间对象，主要是run_matrix中的所有元素。通过Rprof进行分析表明，大部分时间都花在rollapply上。

避免所有中间对象的最简单和最简单的方法是使用for循环。它还使代码清晰。然后你只需要用更快的速度替换对rollapply的调用。

要应用于每个滚动子集的函数很简单：减去测试集。您可以使用stats::embed函数创建滞后矩阵，然后利用R的回收规则从每列中减去测试向量。我创建的功能是：

calc_run_sum <- function(A, train_length, test_length) {
  run_length <- length(A) - train_length - test_length + 1L
  window_size <- train_length - test_length + 1L

  # Essentially what embed() does, but with column order reversed
  # (part of my adaptation of echasnovski's correction)
  train_lags <- 1L:test_length +
                rep.int(1L:window_size, rep.int(test_length, window_size)) - 1L
  dims <- c(test_length, window_size)  # lag matrix dims are always the same

  # pre-allocate result matrix
  run_sum <- matrix(NA, window_size, run_length)

  # loop over each run length
  for (i in seq_len(run_length)) {
    # test set indices and vector
    test_beg <- (train_length + i)
    test_end <- (train_length + test_length + i - 1)

    # echasnovski's correction
    #test_set <- rep(test_set, each = train_length - test_length + 1)
    #lag_matrix <- embed(A[i:(test_beg - 1)], test_length)
    #run_sum[,i] <- rowMeans(lag_matrix - test_set, na.rm = TRUE)

    # My adaptation of echasnovski's correction
    # (requires train_lags object created outside the loop)
    test_set <- A[test_beg:test_end]
    train_set <- A[i:(test_beg - 1L)]
    lag_matrix <- train_set[train_lags]
    dim(lag_matrix) <- dims
    run_sum[,i] <- colMeans(lag_matrix - test_set, na.rm = TRUE)
  }
  run_sum
}

现在，对于一些基准测试。我使用了以下输入数据：

library(zoo) 
set.seed(21)
A <- runif(10000)*200
train.length <- 200
test.length <- 100

以下是您原始方法的时间安排：

system.time({
  run.length <- length(A) - train.length - test.length + 1
  # Form test sets
  test.sets <- sapply(1:run.length, function(x) {
    A[(train.length + x):(train.length + test.length + x - 1)]
  })
  # Generate run_sub_matrices
  run_matrix <- lapply(1:run.length, function(x) {
    rm <- rollapply(A[x:(train.length + x - 1)], width = test.length, by = 1,
                    FUN = function(y) { y - test.sets[, x] })
  })
  # Genereate run_sum_matrices
  run_sum <- sapply(run_matrix, function(x) {
    rowSums(x, na.rm = T) / apply(x, 1,  function(y) {
  sum(!is.na(y))})
  })
})
#    user  system elapsed 
#  19.868   0.104  19.974

以下是echasnovski's approach的时间安排：

system.time({
  run_data <- generate_run_data(length(A), train.length, test.length)

  run_sum_new <- matrix(
    run_mean_diff(A, run_data$train_start, run_data$test_start,
                  run_data$test_length),
    nrow = train.length - test.length + 1
  )
})
#    user  system elapsed 
#  10.552   0.048  10.602

我的方法的时间安排：

system.time(run_sum_jmu <- calc_run_sum(A, train.length, test.length))
#    user  system elapsed 
#   1.544   0.000   1.548

所有3种方法的输出都是相同的。

identical(run_sum, run_sum_new)
# [1] TRUE
identical(run_sum, run_sum_jmu)
# [1] TRUE

如何提高双滚窗操作的效率？

2 个答案: