Jak dodać mapę termiczną do quantmod :: chart_Series?

Question

Chciałbym wykreślić mapę (-y) ciepła pod nazwą quantmod :: chart_Series(). Jak dodać poniższą mapę cieplną do chart_Series (lub XTS :: plot.xts):

library(quantmod) 

# Get data fro symbol from Google Finance 
symbol <- "SPY" 
src <- "google" 
from <- "2017-01-01" 
symbolData <- getSymbols(symbol, src=src, from=from, auto.assign=FALSE) 

# Calculate simple returns 
symbolData.ret <- ROC(Cl(symbolData), type="discrete") 

# Calculate lagged autocorrelations (Pearson correlation for each value of lag) 
nLags <- 100 
averageLength <- 3 
symbolData.laggedAutocorr <- matrix(0, nLags, NROW(symbolData.ret)) 
for (lag in 2: nLags) { 
    # Set the average length as M 
    if (averageLength == 0) M <- lag 
    else M <- averageLength 
    symbolData.laggedAutocorr[lag, ] <- runCor(symbolData.ret, lag(symbolData.ret, lag), M) 
} 
symbolData.laggedAutocorr[is.na(symbolData.laggedAutocorr)] <- 0 
symbolData.laggedAutocorr.xts <- reclass(t(symbolData.laggedAutocorr), symbolData)ž 
subset <- "2017" 
chart_Series(symbolData, name=symbol, subset=subset) 

# Use transposed symbolData.laggedAutocorr for plot so you have data aligned to symbolData 
# How to add the below heatmap to chart_Series? 
heatmap(symbolData.laggedAutocorr.xts, Rowv = NA, Colv = NA, na.rm = TRUE, labCol = "") 

add_Heatmap <- function(heatmapdata, ...) { 
    lenv <- new.env() 
    lenv$plot_ta <- function(x, heatmapdata, ...) { 
     # fill in body of low level plot calls here 
     # use a switch based on type of TA to draw: bands, bars, lines, dots... 
     xsubset <- x$Env$xsubset 
     #heatmapdata <- heatmapdata[subset] # TODO: Something is wrong if I have a subset here 
     heatmap(heatmapdata, Rowv=NA, Colv=NA, na.rm=TRUE, labCol="") 
     #image(1:NROW(heatmapdata), 1:NCOL(heatmapdata), coredata(heatmapdata), axes=FALSE) 
    } 
    mapply(function(name, value) {assign(name,value,envir=lenv)}, 
      names(list(heatmapdata=heatmapdata,...)), 
      list(heatmapdata=heatmapdata,...)) 
    exp <- parse(text=gsub("list","plot_ta", 
        as.expression(substitute(list(x=current.chob(), 
              heatmapdata=heatmapdata, 
              ...)))), srcfile=NULL) 
    chob <- current.chob() 
    chob$add_frame(ylim=c(0, 0.3), asp=0.3) # need to have a value set for ylim 
    chob$next_frame() 
    chob$replot(exp,env=c(lenv, chob$Env),expr=TRUE) 

    chob 
} 

chart_Series(symbolData) 
add_Heatmap(symbolData.laggedAutocorr.xts) 

Powyższy prawie działa ... Problem jest taki, że termiczna lub obraz jest naniesiona na głównej części chart_Series zamiast poniżej tego. Co zrobić, aby działał prawidłowo?

Answer 1

Mam nadzieję, że jest to przydatne dla innych osób, ponieważ udało mi się uzyskać to działa (do pewnego poziomu). Nadal występują problemy. Zobacz komentarze na końcu kodu poniżej i skomentuj, co zrobić, aby usunąć te problemy.

add_Heatmap <- function(heatmapcol, ..., yvalues=1:NCOL(heatmapcol)) { 
    lenv <- new.env() 

    lenv$plot_ta <- function(x, heatmapcol, ...) { 
     xdata <- x$Env$xdata  # internal main series 
     xsubset <- x$Env$xsubset 
     heatmapcol <- heatmapcol[xsubset] 

     x.pos <- 1:NROW(heatmapcol) 
     segments(axTicksByTime(xdata[xsubset], ticks.on=x$Env$ticks.on), 
       0, 
       axTicksByTime(xdata[xsubset], ticks.on=x$Env$ticks.on), 
       NCOL(heatmapcol), col=x$Env$theme$grid) 

     # TODO: What is faster polgon or rect (https://stackoverflow.com/questions/15627674/efficiency-of-drawing-rectangles-on-image-matrix-in-r) 
     # TODO: What is faster for or lapply? 
#  for (i in 1:NCOL(heatmapcol)) { 
#   rect(x.pos - 1/2, i - 1/2, x.pos + 1/2, i + 1/2 + 1, col=heatmapcol[x.pos, i], border=NA, ...) # base graphics call 
#  } 

     lapply(1:NCOL(heatmapcol), function(i) rect(x.pos - 1/2, i - 1/2, x.pos + 1/2, i + 1/2 + 1, col=heatmapcol[x.pos, i], border=NA, ...)) 
    } 

    mapply(function(name, value) {assign(name,value,envir=lenv)}, 
      names(list(heatmapcol=heatmapcol, ...)), 
      list(heatmapcol=heatmapcol, ...)) 
    exp <- parse(text=gsub("list", "plot_ta", 
        as.expression(substitute(list(x=current.chob(), 
              heatmapcol=heatmapcol, 
              ...)))), srcfile=NULL) 
    chob <- current.chob() 
# chob$add_frame(ylim=c(0, 1),asp=0.15) # add the header frame 
# chob$next_frame()      # move to header frame 

    chob$add_frame(ylim=c(1, NCOL(heatmapcol)), asp=1) # need to have a value set for ylim 
    chob$next_frame() 

    if (length(yvalues) != NCOL(heatmapcol)) { 
     # We have a case when min and max is specified 
     yvalues <- (range(yvalues)[1]):(range(yvalues)[2]) 
    } 

    # add grid lines 
    lenv$grid_lines_val <- function(xdata, x) { 
     ret <- pretty(yvalues) 

     if (ret[1] != min(yvalues)) { 
      if (ret[1] <= min(yvalues)) { 
       ret[1] <- min(yvalues) 
      } else { 
       ret <- c(min(yvalues), ret) 
      } 
     } 

     if (ret[length(ret)] != max(yvalues)) { 
      if (ret[length(ret)] >= max(yvalues)) { 
       ret[length(ret)] <- max(yvalues) 
      } else { 
       ret <- c(ret, max(yvalues)) 
      } 
     } 

     return(ret) 
    } 

    lenv$grid_lines_pos <- function(xdata, x) { 
     ret <- lenv$grid_lines_val(xdata, x) 

     ret <- ret - min(yvalues) 

     return(ret) 
    } 

    exp <- c(exp, 
      # Add axis labels/boxes 
      expression(text(1- 1/3 - max(strwidth(grid_lines_val(xdata, xsubset))), grid_lines_pos(xdata, xsubset), 
         noquote(format(grid_lines_val(xdata, xsubset), justify="right")), 
         col=theme$labels, offset=0, pos=4, cex=0.9)), 
      expression(text(NROW(xdata[xsubset]) + 1/3, grid_lines_pos(xdata, xsubset), 
         noquote(format(grid_lines_val(xdata, xsubset), justify="right")), 
         col=theme$labels, offset=0, pos=4, cex=0.9))) 

    chob$replot(exp, env=c(lenv, chob$Env), expr=TRUE) 

    chob 
} 

colorsForHeatmap<-function(heatmapdata) { 
    heatmapdata <- 0.5*(heatmapdata + 1) 

    r <- coredata((heatmapdata > 0.5)*round(255*(2 - 2*heatmapdata)) + (heatmapdata <= 0.5)*255) 
    g <- coredata((heatmapdata > 0.5)*255 + (heatmapdata <= 0.5)*round(255*2*heatmapdata)) 
    b <- coredata(heatmapdata*0.0) # Set to 0 for all 

    col <- rgb(r, g, b, maxColorValue=255) 
    dim(col) <- dim(r) 

    col <- reclass(col, heatmapdata) 

    return(col) 
} 

library(quantmod) 

# Get data for symbol from Google Finance 
symbol <- "SPY" 
src <- "google" 
from <- "1990-01-01" 
symbolData <- getSymbols(symbol, src=src, from=from, auto.assign=FALSE) 

# Calculate simple returns 
symbolData.ret <- ROC(Cl(symbolData), type="discrete") 

# Calculate lagged autocorrelations (Pearson correlation for each value of lag) 
nLags <- 48 
averageLength <- 3 
symbolData.laggedAutocorr <- matrix(0, NROW(symbolData.ret), nLags) 
for (lag in 2:nLags) { 
    # Set the average length as M 
    if (averageLength == 0) M <- lag 
    else M <- averageLength 
    symbolData.laggedAutocorr[, lag] <- runCor(symbolData.ret, lag(symbolData.ret, lag), M) 
} 
symbolData.laggedAutocorr[is.na(symbolData.laggedAutocorr)] <- 0 

symbolData.laggedAutocorr.xts <- xts(symbolData.laggedAutocorr, index(symbolData)) 

heatmapColData <- colorsForHeatmap(symbolData.laggedAutocorr.xts) 

symbolData.rsi2 <- RSI(Cl(symbolData), n=2) 

subset <- "2011/" 
chart_Series(symbolData, name=symbol, subset=subset) 
add_Heatmap(heatmapColData, yvalues=2:nLags) 

# TODO: There are still issues: 
# - add a horizontal line 
five <- symbolData[, 1] 
five[, 1] <- 5 
add_TA(five, col="violet", on=3) 
#> add_TA(five, col="violet", on=3) 
#Error in ranges[[frame]] : subscript out of bounds 
# - add RSI for example and heatmap disappears 
add_RSI() 
# - or add TA 
add_TA(symbolData.rsi2) 
# What to do so it works like intended: I can add lines on top of heatmaps? I can add other TAs in new panes?