WMA (Weighted Moving Average) 계산 속도 향상

Question

15 일 막대의 지수 이동 평균을 계산하려고하지만 각 (끝) 날/막대의 15 일 막대 EMA의 "진화"를보고 싶습니다. 그래서, 나는 15 일간의 술집을 가지고 있음을 의미합니다. 새로운 데이터가 매일 들어 오면 새로운 정보를 사용하여 EMA를 다시 계산하고 싶습니다. 실제로 나는 15 일간의 바를 가지고 있고, 매일 매일 새로운 15 일간의 바가 커지기 시작하고 새로운 바가 EMA 계산에 사용되기로되어 있습니다.

2012-01-01 (이 예에서는 각 캘린더 날짜에 대한 데이터가 있음)에서 시작한다고 가정 해 보겠습니다. 2012-01-15 끝 부분에 첫 번째 완전한 15 일 표시 줄이 있습니다. 2012-03-01에 4 일간의 15 일간의 바가 완료되면 4 바 EMA (EMA (x, n = 4))를 계산할 수 있습니다. 2012-03-02 끝에서 우리는이 순간까지 가지고있는 정보를 사용하고 2012-03-02에 대한 EMA를 계산합니다. 2012-03-02에 대한 OHLC가 진행중인 15 일 바입니다. 그래서 우리는 2012-03-02에 4 개의 완전한 막대와 막대를 가져 와서 EMA (x, n = 4)를 계산합니다. 그런 다음 다른 날을 기다리며, 진행중인 새로운 15 일 바가 어떻게되었는지 확인하고 (자세한 내용은 to.period.cumulative의 기능 참조) EMA에 대한 새로운 가치를 계산합니다 ... 앞으로 15 일 동안 ... 함수 EMA 자세한 내용은 아래에서 ...

아래에서 지금까지 무엇을 생각해 낼 수 있었는지 찾아보십시오. 성능은 나에게는 받아 들일 수 없으며 제한된 R 지식으로는 더 빠르게 할 수 없습니다. 내 시스템에서

library(quantmod) 

do.call.rbind <- function(lst) { 
    while(length(lst) > 1) { 
     idxlst <- seq(from=1, to=length(lst), by=2) 

     lst <- lapply(idxlst, function(i) { 
        if(i==length(lst)) { return(lst[[i]]) } 

        return(rbind(lst[[i]], lst[[i+1]])) 
       }) 
    } 
    lst[[1]] 
} 

to.period.cumulative <- function(x, name=NULL, period="days", numPeriods=15) { 
    if(is.null(name)) 
     name <- deparse(substitute(x)) 

    cnames <- c("Open", "High", "Low", "Close") 
    if (has.Vo(x)) 
     cnames <- c(cnames, "Volume") 

    cnames <- paste(name, cnames, sep=".") 

    if (quantmod:::is.OHLCV(x)) { 
     x <- OHLCV(x) 
     out <- do.call.rbind( 
       lapply(split(x, f=period, k=numPeriods), 
         function(x) cbind(rep(first(x[,1]), NROW(x[,1])), 
           cummax(x[,2]), cummin(x[,3]), x[,4], cumsum(x[,5])))) 
    } else if (quantmod:::is.OHLC(x)) { 
     x <- OHLC(x) 
     out <- do.call.rbind( 
       lapply(split(x, f=period, k=numPeriods), 
         function(x) cbind(rep(first(x[,1]), NROW(x[,1])), 
           cummax(x[,2]), cummin(x[,3]), x[,4]))) 
    } else { 
     stop("Object does not have OHLC(V).") 
    } 

    colnames(out) <- cnames 

    return(out) 
} 

EMA.cumulative<-function(cumulativeBars, nEMA = 4, period="days", numPeriods=15) { 
    barsEndptCl <- Cl(cumulativeBars[endpoints(cumulativeBars, on=period,  k=numPeriods)]) 

    # TODO: This is sloooooooooooooooooow... 
    outEMA <- do.call.rbind(
      lapply(split(Cl(cumulativeBars), period), 
        function(x) { 
         previousFullBars <- barsEndptCl[index(barsEndptCl) < last(index(x)), ] 
         if (NROW(previousFullBars) >= (nEMA - 1)) { 
           last(EMA(last(rbind(previousFullBars, x), n=(nEMA + 1)), n=nEMA)) 
         } else { 
          xts(NA, order.by=index(x)) 
         } 
        })) 

    colnames(outEMA) <- paste("EMA", nEMA, sep="") 

    return(outEMA) 
} 

getSymbols("SPY", from="2010-01-01") 

SPY.cumulative <- to.period.cumulative(SPY, , name="SPY") 

system.time(
     SPY.EMA <- EMA.cumulative(SPY.cumulative) 
) 

는 그것이이 사용하는 순수 R을 달성 할 수 ...

user system elapsed 
    4.708 0.000 4.410 

가능한 실행 시간이 1 초 미만이 될 것이라고한다?

이 게시물은 Optimize moving averages calculation - is it possible?에 연결되어있어서 답변을 찾을 수 없습니다. 이제는 속도를 높이려는 것에 대한 자세한 설명과 함께 재현 가능한 예제를 만들 수있었습니다. 나는 그 질문이 더 이해되기를 바란다.

속도를 높이는 방법에 대한 아이디어는 높이 평가됩니다.

Answer 1

나는 R을 사용하여 나의 질문에 대한 만족스러운 해결책을 찾지 못했습니다. 그래서 나는 오래된 도구 인 C 언어를 사용했고 결과는 내가 기대했던 것보다 낫습니다. Rcpp, 인라인 등의 훌륭한 도구를 사용하여 "밀고"주셔서 감사드립니다. 나는 미래의 성능 요구 사항이있을 때마다 R을 사용하여 만날 수 없을 때마다 C를 R에 추가하고 성능을 확인합니다. 그래서 성능 문제에 대한 내 코드와 해결책을 아래에서 확인하십시오.

# How to speedup cumulative EMA calculation 
# 
############################################################################### 

library(quantmod) 
library(Rcpp) 
library(inline) 
library(rbenchmark) 

do.call.rbind <- function(lst) { 
    while(length(lst) > 1) { 
     idxlst <- seq(from=1, to=length(lst), by=2) 

     lst <- lapply(idxlst, function(i) { 
        if(i==length(lst)) { return(lst[[i]]) } 

        return(rbind(lst[[i]], lst[[i+1]])) 
       }) 
    } 
    lst[[1]] 
} 

to.period.cumulative <- function(x, name=NULL, period="days", numPeriods=15) { 
    if(is.null(name)) 
     name <- deparse(substitute(x)) 

    cnames <- c("Open", "High", "Low", "Close") 
    if (has.Vo(x)) 
     cnames <- c(cnames, "Volume") 

    cnames <- paste(name, cnames, sep=".") 

    if (quantmod:::is.OHLCV(x)) { 
     x <- quantmod:::OHLCV(x) 
     out <- do.call.rbind( 
       lapply(split(x, f=period, k=numPeriods), 
         function(x) cbind(rep(first(x[,1]), NROW(x[,1])), 
           cummax(x[,2]), cummin(x[,3]), x[,4], cumsum(x[,5])))) 
    } else if (quantmod:::is.OHLC(x)) { 
     x <- OHLC(x) 
     out <- do.call.rbind( 
       lapply(split(x, f=period, k=numPeriods), 
         function(x) cbind(rep(first(x[,1]), NROW(x[,1])), 
           cummax(x[,2]), cummin(x[,3]), x[,4]))) 
    } else { 
     stop("Object does not have OHLC(V).") 
    } 

    colnames(out) <- cnames 

    return(out) 
} 

EMA.cumulative<-function(cumulativeBars, nEMA = 4, period="days", numPeriods=15) { 
    barsEndptCl <- Cl(cumulativeBars[endpoints(cumulativeBars, on=period, k=numPeriods)]) 

    # TODO: This is sloooooooooooooooooow... 
    outEMA <- do.call.rbind(
      lapply(split(Cl(cumulativeBars), period), 
        function(x) { 
         previousFullBars <- barsEndptCl[index(barsEndptCl) < last(index(x)), ] 
         if (NROW(previousFullBars) >= (nEMA - 1)) { 
           last(EMA(last(rbind(previousFullBars, x), n=(nEMA + 1)), n=nEMA)) 
         } else { 
          xts(NA, order.by=index(x)) 
         } 
        })) 

    colnames(outEMA) <- paste("EMA", nEMA, sep="") 

    return(outEMA) 
} 

EMA.c.c.code <- ' 
    /* Initalize loop and PROTECT counters */ 
    int i, P=0; 

    /* ensure that cumbars and fullbarsrep is double */ 
    if(TYPEOF(cumbars) != REALSXP) { 
     PROTECT(cumbars = coerceVector(cumbars, REALSXP)); P++; 
    } 

    /* Pointers to function arguments */ 
    double *d_cumbars = REAL(cumbars); 
    int i_nper = asInteger(nperiod); 
    int i_n = asInteger(n); 
    double d_ratio = asReal(ratio); 

    /* Input object length */ 
    int nr = nrows(cumbars); 

    /* Initalize result R object */ 
    SEXP result; 
    PROTECT(result = allocVector(REALSXP,nr)); P++; 
    double *d_result = REAL(result); 

    /* Find first non-NA input value */ 
    int beg = i_n*i_nper - 1; 
    d_result[beg] = 0; 
    for(i = 0; i <= beg; i++) { 
     /* Account for leading NAs in input */ 
     if(ISNA(d_cumbars[i])) { 
      d_result[i] = NA_REAL; 
      beg++; 
      d_result[beg] = 0; 
      continue; 
     } 
     /* Set leading NAs in output */ 
     if(i < beg) { 
      d_result[i] = NA_REAL; 
     } 
     /* Raw mean to start EMA - but only on full bars*/ 
     if ((i != 0) && (i%i_nper == (i_nper - 1))) { 
      d_result[beg] += d_cumbars[i]/i_n; 
     } 
    } 

    /* Loop over non-NA input values */ 
    int i_lookback = 0; 
    for(i = beg+1; i < nr; i++) { 
     i_lookback = i%i_nper; 

     if (i_lookback == 0) { 
      i_lookback = 1; 
     } 
     /*Previous result should be based only on full bars*/ 
     d_result[i] = d_cumbars[i] * d_ratio + d_result[i-i_lookback] * (1-d_ratio); 
    } 

    /* UNPROTECT R objects and return result */ 
    UNPROTECT(P); 
    return(result); 
' 

EMA.c.c <- cfunction(signature(cumbars="numeric", nperiod="numeric", n="numeric",  ratio="numeric"), EMA.c.c.code) 

EMA.cumulative.c<-function(cumulativeBars, nEMA = 4, period="days", numPeriods=15) { 
    ratio <- 2/(nEMA+1) 

    outEMA <- EMA.c.c(cumbars=Cl(cumulativeBars), nperiod=numPeriods, n=nEMA, ratio=ratio) 

    outEMA <- reclass(outEMA, Cl(cumulativeBars)) 

    colnames(outEMA) <- paste("EMA", nEMA, sep="") 

    return(outEMA) 
} 

getSymbols("SPY", from="2010-01-01") 

SPY.cumulative <- to.period.cumulative(SPY, name="SPY") 

system.time(
     SPY.EMA <- EMA.cumulative(SPY.cumulative) 
) 

system.time(
     SPY.EMA.c <- EMA.cumulative.c(SPY.cumulative) 
) 


res <- benchmark(EMA.cumulative(SPY.cumulative), EMA.cumulative.c(SPY.cumulative), 
     columns=c("test", "replications", "elapsed", "relative", "user.self", "sys.self"), 
     order="relative", 
     replications=10) 

print(res) 

편집 :

> print(res) 
           test replications elapsed relative user.self 
2 EMA.cumulative.c(SPY.cumulative)   10 0.026 1.000  0.024 
1 EMA.cumulative(SPY.cumulative)   10 57.732 2220.462 56.755 

: 내 성가신 이상의 성능 향상의 표시를 제공하기 위해 R 여기에 인쇄 밖으로 (I 효과에 내가 루프를 두 번 생성 한 이후가 더 잘 할 수 확신)

내 기준에 따라 개선 된 SF 유형 ...