堆棧內存溢出
  簡體   English   中英

加快WMA（加權移動平均線）計算

[英]Speed up WMA (Weighted Moving Average) calculation

 原文  2012-01-03 23:20:03  3   1    r/ finance

問題描述

我試圖在15天的條形圖上計算指數移動平均線，但是想要在每天（結束日）/條形圖上看到15天條形EMA的“演變”。 所以，這意味着我有15天的酒吧。 當新數據每天進入時，我想使用新信息重新計算EMA。 實際上我有15天的酒吧然后，每天后我的新15天酒吧開始增長，每個新的酒吧應該用於EMA計算以及之前的15天酒吧。

讓我們說我們從2012-01-01開始（我們有這個例子的每個日歷日的數據），在2012-01-15結束時我們有第一個完整的15天吧。 在2012-03-01完成4個完整的15天欄后，我們可以開始計算4 bar EMA（EMA（x，n = 4））。 在2012-03-02結束時，我們使用到目前為止的信息並在2012-03-02計算EMA，假裝2012-03-02的OHLC正在進行中。 因此，我們在2012-03-02獲取4個完整的條形和條形並計算EMA（x，n = 4）。 然后我們再等一天，看看正在進行的新15天酒吧發生了什么（請參閱下面的函數to.period.cumulative了解詳細信息）並計算EMA的新值......所以在接下來的15天之后......見函數EMA.cumulative以下詳細信息......

請在下面找到我能想到的東西。 性能對我來說是不可接受的，因為我的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)
)

在我的系統上它需要 

   user  system elapsed 
  4.708   0.000   4.410

可接受的執行時間不到一秒......是否可以使用純R實現這一目標？

這篇文章與優化移動平均線計算有關 - 是否可能？ 我沒有得到答案的地方。 我現在能夠創建一個可重現的示例，更詳細地解釋我想要加速的內容。 我希望這個問題現在更有意義。

關於如何加快這一點的任何想法都受到高度贊賞。

1 個解決方案

解決方案1
 6 已采納  2012-01-15 21:36:08

我沒有找到一個滿意的解決方案來解決我使用R的問題。所以我采用了舊的工具，c語言，結果比我想象的要好。 感謝“推”我使用Rcpp，內聯等偉大的工具。驚人的。 我想，每當我有未來的性能要求而無法使用RI時，會將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)

編輯：為了表明我的繁瑣的性能改進（我相信它可以做得更好，因為實際上我已經創建了雙循環）R這里是打印輸出： 

> 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

所以，根據我的標准，SF類型的改進......

暫無
暫無

聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.

相關問題 按日期加權移動平均線R. R中加權最小二乘均值估計的加速逆計算 加快分位數計算 指數加權移動平均值的快速R實現？ 如何使用自定義權重計算加權移動平均線？ R中每個日期具有多個觀測值的移動加權平均值 計算絕對距離/加權移動平均值。 斯塔塔或 R 申請，mapply？ 我正在嘗試計算R中的加權移動平均值 使用dplyr迭代計算指數加權移動平均值 用R加速迭代循環計算
相關標簽
 
粵ICP備18138465號  © 2020-2024 STACKOOM.COM