Копирование вложенного цикла с помощью sapply

Question

Я хочу скопировать вложенный цикл с помощью sapply или других примененных функций. У меня есть набор данных, состоящий из ежемесячной доходности 100 акций. Я хочу вычислить сумму ежемесячных доходов от t-6 до t-2 для каждой акции. Здесь представлено каждое наблюдение. Для этого я создал следующий вложенный цикл. Теперь я хочу сделать то же самое с семьей. Я пытался, но это не работает. Я думаю, что я делаю ошибку. Пожалуйста, проверьте мой код.

x <- matrix(rnorm(1e4), nrow=100, ncol=100)
s=6
k=1
XSMOM = x
XSMOM[1:nrow(XSMOM),1:ncol(XSMOM)] <- NA
# Using nested loops
for (i in 1:ncol(x)){

  for (t in (s + 1):nrow(x)){
    XSMOM[t,i] =  sum(x[(t-s):(t-1-k),i])

  }
}
## using sapply
sapply(1:ncol(x),function(m)
sapply(s+1:nrow(x),function(n)
sum(x[(n-s):(n-s-k),m])

Answer 1

В коде есть несколько ошибок. Следует отметить, что вы должны предоставить минимальный пример.

x <- matrix(rnorm(50), nrow=10, ncol=5)
XSMOM <- matrix(NA_real_, ncol = ncol(x), nrow = nrow(x))

s=6; k=1

sapply(1:ncol(x),
       function(i) { # need curly bracket; changed var from m to i to match loop
         sapply((s+1):nrow(x),function(t) { # need curly bracket; changed from n to t
           sum(x[(t-s):(t-1-k),i]) # copied original loop function; you had n-s-k
         })
       })

Для большей скорости вы можете посмотреть rcpproll или data.table

library(data.table)
simplify2array(shift(frollsum(as.data.frame(x), n = s-1), 2))

library(RcppRoll)
XSMOM <- matrix(NA_real_, ncol = ncol(x), nrow = nrow(x))

XSMOM[-(1:s), ]  <- roll_sumr(x, n = s-1)[(s-1):(nrow(x) - k - 1), ]
XSMOM

Производительность всего:

# for x <- matrix(rnorm(1E4), nrow=100, ncol=100)
# A tibble: 6 x 13
  expression         min  median `itr/sec` mem_alloc
  <bch:expr>     <bch:t> <bch:t>     <dbl> <bch:byt>
1 original_loop   19.8ms  20.5ms     48.2   140.71KB
2 double_sapply   27.2ms  27.7ms     35.1   624.49KB
3 apply_sapply    20.5ms  21.1ms     46.5   827.84KB
4 zoo_rollapply  120.6ms 122.1ms      8.19   11.04MB
5 rcpp_roll      243.6us 250.8us   3771.    400.53KB
6 dt_froll_shift 720.3us 806.9us   1186.      2.01MB

# code for reference
library(data.table)
library(zoo)
library(RcppRoll)
library(bench)

x <- matrix(rnorm(1E4), nrow=100, ncol=100)
# x <- matrix(rnorm(50), nrow=10, ncol=5)
s=6
k=1
XSMOM <- matrix(NA_real_, ncol = ncol(x), nrow = nrow(x))

bench::mark(
  original_loop = {
    XSMOM <- matrix(NA_real_, ncol = ncol(x), nrow = nrow(x))

    for (i in 1:ncol(x)){
      for (t in (s + 1):nrow(x)){
        XSMOM[t,i] =  sum(x[(t-s):(t-1-k),i])
      }
    }
    XSMOM
  }
  ,
  double_sapply = {
    XSMOM <- matrix(NA_real_, ncol = ncol(x), nrow = nrow(x))
    XSMOM[-(1:s), ] <- sapply(1:ncol(x),
                            function(i) {
                              sapply((s+1):nrow(x),function(t) {
                                sum(x[(t-s):(t-1-k),i])
                                }
                              )
                              }
                            )
    XSMOM
  }
  ,
  apply_sapply = {
    XSMOM <- matrix(NA_real_, ncol = ncol(x), nrow = nrow(x))
    XSMOM[-(1:s), ] <- apply(x, 2, 
          function(col) {
            sapply((s+1):nrow(x), function(t) {
              sum(col[(t-s):(t-1-k)])
            })
          })
    XSMOM
  }
  ,
  zoo_rollapply = {
    # XSMOM <- rollapplyr(x,
    #            by.column = T,
    #            width = list(-s:-(k + 1)),
    #            sum,
    #            fill = NA)
    XSMOM <- matrix(NA_real_, ncol = ncol(x), nrow = nrow(x))
    XSMOM[-(1:s), ] <-head(rollsumr(x, by.column = T, k = s-1), -(k+1))
    XSMOM
  }
  ,
  rcpp_roll = {
    XSMOM <- matrix(NA_real_, ncol = ncol(x), nrow = nrow(x))
    XSMOM[-(1:s), ]  <- roll_sumr(x, n = s-1)[(s-1):(nrow(x) - k - 1), ]
    XSMOM
    }
  ,
  dt_froll_shift = {
    simplify2array(shift(frollsum(as.data.frame(x), n = s-1), 2))
  }
)