r - chart.TimeSeries 不遮蔽期间区域

Question

我正在尝试使用“性能分析”包中的 chart.Timeseries 生成一个带有阴影区域的图。结果图没有阴影区域。我的代码（来自函数帮助页面的简化示例）是：

library(PerformanceAnalytics)

cycles.dates<-c("2001-03/2001-11","2007-12/2009-06")

data(edhec)

R=edhec[,"Funds of Funds",drop=FALSE]

Return.cumulative = cumprod(1+R) - 1

chart.TimeSeries(Return.cumulative, 
                 period.areas = cycles.dates, 
                 period.color = "blue")

我的结果图

谢谢

标签： r

Answer 1

如果要绘制阴影区域chart.TimeSeries，则需要定义至少一条事件线。这是一个例子：

chart.TimeSeries(Return.cumulative, 
                 grid.color="white",
                 period.areas = cycles.dates, 
                 period.color = "#0000FF22",
                 event.lines = c("Jan 97"), 
                 event.labels = c(""),
                 event.color="white")

不幸的是，该参数event.color不起作用，因为在函数内部PerformanceAnalytics:::chart.TimeSeries.base未使用此参数。
我建议修改PerformanceAnalytics:::chart.TimeSeries.base如下：

chart.TimeSeries.base <- function (R, auto.grid = TRUE, xaxis = TRUE, 
    yaxis = TRUE, yaxis.right = FALSE, 
    type = "l", lty = 1, lwd = 2, las = par("las"), main = NULL, 
    ylab = NULL, xlab = "", date.format.in = "%Y-%m-%d", date.format = NULL, 
    xlim = NULL, ylim = NULL, element.color = "darkgray", event.lines = NULL, 
    event.labels = NULL, period.areas = NULL, event.color = "darkgray", 
    period.color = "aliceblue", colorset = (1:12), pch = (1:12), 
    legend.loc = NULL, ylog = FALSE, cex.axis = 0.8, cex.legend = 0.8, 
    cex.lab = 1, cex.labels = 0.8, cex.main = 1, major.ticks = "auto", 
    minor.ticks = TRUE, grid.color = "lightgray", grid.lty = "dotted", 
    xaxis.labels = NULL, yaxis.pct = FALSE, ...) 
{
    y = checkData(R)
    columns = ncol(y)
    rows = nrow(y)
    columnnames = colnames(y)
    if (is.null(date.format)) {
        freq = periodicity(y)
        yr_eq <- ifelse(format(index(first(y)), format = "%Y") == 
            format(index(last(y)), format = "%Y"), TRUE, FALSE)
        switch(freq$scale, seconds = {
            date.format = "%H:%M"
        }, minute = {
            date.format = "%H:%M"
        }, hourly = {
            date.format = "%d %H"
        }, daily = {
            if (yr_eq) date.format = "%b %d" else date.format = "%Y-%m-%d"
        }, weekly = {
            if (yr_eq) date.format = "%b %d" else date.format = "%Y-%m-%d"
        }, monthly = {
            if (yr_eq) date.format = "%b" else date.format = "%b %y"
        }, quarterly = {
            if (yr_eq) date.format = "%b" else date.format = "%b %y"
        }, yearly = {
            date.format = "%Y"
        })
    }
    rownames = as.Date(time(y))
    rownames = format(strptime(rownames, format = date.format.in), 
        date.format)
    time.scale = periodicity(y)$scale
    ep = axTicksByTime(y, major.ticks, format.labels = date.format)
    logaxis = ""
    if (ylog) {
        logaxis = "y"
    }
    if (yaxis.pct) 
        y = y * 100
    if (is.null(xlim[1])) 
        xlim = c(1, rows)
    if (is.null(ylim[1])) {
        ylim = as.numeric(range(y, na.rm = TRUE))
    }
    if (yaxis) 
        yaxis.left = TRUE
    else yaxis.left = FALSE
    if (is.null(main)) 
        main = columnnames[1]
    p <- plot.xts(x = y, y = NULL, ..., col = colorset, type = type, 
        lty = lty, lwd = lwd, main = main, ylim = ylim, yaxis.left = yaxis.left, 
        yaxis.right = yaxis.right, major.ticks = major.ticks, 
        minor.ticks = minor.ticks, grid.ticks.lty = grid.lty, 
        grid.col = grid.color, legend.loc = NULL, pch = pch)
    if (!is.null(event.lines)) {
        event.ind = NULL
        for (event in 1:length(event.lines)) {
            event.ind = c(event.ind, grep(event.lines[event], 
                rownames))
        }
        number.event.labels = ((length(event.labels) - length(event.ind) + 
            1):length(event.labels))
        if (!is.null(period.areas)) {
            period.dat = lapply(period.areas, function(x, y) c(first(index(y[x])), 
                last(index(y[x]))), y = y)
            period.ind = NULL
            opar <- par(font = 1)
            par(font = 2)
            p$Env$period.color <- period.color
            #############################
            # Added col = event.color
            #############################
            p <- addEventLines(xts(event.labels[number.event.labels], 
                time(y)[event.ind]), srt = 90, offset = 1.2, 
                pos = 2, lty = 2, col = event.color, ...)
            for (period in 1:length(period.dat)) {
                if (!is.na(period.dat[[period]][1])) 
                  p <- addPolygon(xts(matrix(c(min(y), max(y), 
                    min(y), max(y)), ncol = 2, byrow = TRUE), 
                    period.dat[[period]]), on = 1, col = period.color, 
                    ...)
            }
            par(opar)
        }
    }
    p$Env$element.color <- element.color
    p <- addSeries(xts(rep(0, rows), time(y)), col = element.color, 
        on = 1)
    if (length(lwd) < columns) 
        lwd = rep(lwd, columns)
    if (length(lty) < columns) 
        lty = rep(lty, columns)
    if (length(pch) < columns) 
        pch = rep(pch, columns)
    if (!is.null(legend.loc)) {
        if (!hasArg(legend.names)) 
            legend.names <- columnnames
        p$Env$cex.legend <- cex.legend
        p <- addLegend(legend.loc, legend.names, lty = lty, lwd = lwd, 
            cex = cex.legend, ...)
    }
    return(p)
}

并使用它来替换PerformanceAnalytics包中的现有功能：

assignInNamespace(x="chart.TimeSeries.base", 
                  value=chart.TimeSeries.base, ns="PerformanceAnalytics")

chart.TimeSeries(Return.cumulative, 
                 grid.color="white",
                 period.areas = cycles.dates, 
                 period.color = "#0000FF22",
                 event.lines = c("Jan 97"), 
                 event.labels = c(""),
                 event.color="white")