我想制作 charts.PerformanceSummary 包中可用的 PerformanceAnalytics 基本功能的“ggplot 版本”,因为我认为 ggplot 在编辑图像方面通常更漂亮,理论上更强大。我已经相当接近了,但有一些问题我需要一些帮助。即:

  • 减少了图例占用的空间量,当上面有超过 10 行时,它会变得可怕/丑陋......(仅行颜色和名称就足够了)
  • 增加 Daily_Returns facet 的大小以匹配 charts.PerformanceSummary in PerformanceAnalytics
  • 有一个选项指定在 Daily_Returns 方面的每日 yield 系列中显示哪个 Assets ,而不是总是使用第一列,这与 charts.PerformanceSummary
  • 中发生的情况不同

    如果有更好的方法可以使用 gridExtra 而不是 facets 来做到这一点......我并不反对人们向我展示如何看起来更好......

    这里的问题是美学,我想可能易于操作,因为 PerformanceAnalytics 已经有一个很好的工作示例,我只是想让它更漂亮/更专业......

    除了这个奖励积分之外,我希望能够在每个 Assets 的图表上或下方或侧面的某个地方显示一些与它相关的性能统计数据......不太确定最好显示或显示的位置此信息。

    此外,如果人们对此有建议,我不会反对建议清理我的代码的部分。

    这是我可重复的示例...

    首先生成返回数据:
    require(xts)
    X.stock.rtns <- xts(rnorm(1000,0.00001,0.0003), Sys.Date()-(1000:1))
    Y.stock.rtns <- xts(rnorm(1000,0.00003,0.0004), Sys.Date()-(1000:1))
    Z.stock.rtns <- xts(rnorm(1000,0.00005,0.0005), Sys.Date()-(1000:1))
    rtn.obj <- merge(X.stock.rtns , Y.stock.rtns, Z.stock.rtns)
    colnames(rtn.obj) <- c("x.stock.rtns","y.stock.rtns","z.stock.rtns")
    

    我想从以下结果复制图像:
    require(PerformanceAnalytics)
    charts.PerformanceSummary(rtn.obj, geometric=TRUE)
    

    这是我迄今为止的尝试......
    gg.charts.PerformanceSummary <- function(rtn.obj, geometric=TRUE, main="",plot=TRUE){
    
        # load libraries
    suppressPackageStartupMessages(require(ggplot2))
    suppressPackageStartupMessages(require(scales))
    suppressPackageStartupMessages(require(reshape))
    suppressPackageStartupMessages(require(PerformanceAnalytics))
        # create function to clean returns if having NAs in data
        clean.rtn.xts <- function(univ.rtn.xts.obj,na.replace=0){
        univ.rtn.xts.obj[is.na(univ.rtn.xts.obj)]<- na.replace
        univ.rtn.xts.obj
    }
        # Create cumulative return function
    cum.rtn <- function(clean.xts.obj, g=TRUE){
        x <- clean.xts.obj
        if(g==TRUE){y <- cumprod(x+1)-1} else {y <- cumsum(x)}
        y
    }
        # Create function to calculate drawdowns
    dd.xts <- function(clean.xts.obj, g=TRUE){
        x <- clean.xts.obj
        if(g==TRUE){y <- Drawdowns(x)} else {y <- Drawdowns(x,geometric=FALSE)}
        y
    }
        # create a function to create a dataframe to be usable in ggplot to replicate charts.PerformanceSummary
    cps.df <- function(xts.obj,geometric){
        x <- clean.rtn.xts(xts.obj)
        series.name <- colnames(xts.obj)[1]
        tmp <- cum.rtn(x,geometric)
        tmp$rtn <- x
        tmp$dd <- dd.xts(x,geometric)
        colnames(tmp) <- c("Cumulative_Return","Daily_Return","Drawdown")
        tmp.df <- as.data.frame(coredata(tmp))
        tmp.df$Date <- as.POSIXct(index(tmp))
        tmp.df.long <- melt(tmp.df,id.var="Date")
        tmp.df.long$asset <- rep(series.name,nrow(tmp.df.long))
        tmp.df.long
    }
    # A conditional statement altering the plot according to the number of assets
    if(ncol(rtn.obj)==1){
                # using the cps.df function
        df <- cps.df(rtn.obj,geometric)
                # adding in a title string if need be
        if(main==""){
            title.string <- paste0(df$asset[1]," Performance")
        } else {
            title.string <- main
        }
                # generating the ggplot output with all the added extras....
        gg.xts <- ggplot(df, aes_string(x="Date",y="value",group="variable"))+
                    facet_grid(variable ~ ., scales="free", space="free")+
                    geom_line(data=subset(df,variable=="Cumulative_Return"))+
                    geom_bar(data=subset(df,variable=="Daily_Return"),stat="identity")+
                    geom_line(data=subset(df,variable=="Drawdown"))+
                    ylab("")+
                    geom_abline(intercept=0,slope=0,alpha=0.3)+
                    ggtitle(title.string)+
                    theme(axis.text.x = element_text(angle = 45, hjust = 1))+
                    scale_x_datetime(breaks = date_breaks("6 months"), labels = date_format("%d/%m/%Y"))
    
    } else {
                # a few extra bits to deal with the added rtn columns
        no.of.assets <- ncol(rtn.obj)
        asset.names <- colnames(rtn.obj)
        df <- do.call(rbind,lapply(1:no.of.assets, function(x){cps.df(rtn.obj[,x],geometric)}))
        df$asset <- ordered(df$asset, levels=asset.names)
        if(main==""){
            title.string <- paste0(df$asset[1]," Performance")
        } else {
            title.string <- main
        }
        if(no.of.assets>5){legend.rows <- 5} else {legend.rows <- no.of.assets}
        gg.xts <- ggplot(df, aes_string(x="Date", y="value",group="asset"))+
          facet_grid(variable~.,scales="free",space="free")+
          geom_line(data=subset(df,variable=="Cumulative_Return"),aes(colour=factor(asset)))+
          geom_bar(data=subset(df,variable=="Daily_Return"),stat="identity",aes(fill=factor(asset),colour=factor(asset)),position="dodge")+
          geom_line(data=subset(df,variable=="Drawdown"),aes(colour=factor(asset)))+
          ylab("")+
          geom_abline(intercept=0,slope=0,alpha=0.3)+
          ggtitle(title.string)+
          theme(legend.title=element_blank(), legend.position=c(0,1), legend.justification=c(0,1),
                axis.text.x = element_text(angle = 45, hjust = 1))+
          guides(col=guide_legend(nrow=legend.rows))+
          scale_x_datetime(breaks = date_breaks("6 months"), labels = date_format("%d/%m/%Y"))
    
    }
    
    assign("gg.xts", gg.xts,envir=.GlobalEnv)
    if(plot==TRUE){
        plot(gg.xts)
    } else {}
    
    }
    # seeing the ggplot equivalent....
    gg.charts.PerformanceSummary(rtn.obj, geometric=TRUE)
    

    最佳答案

    我只是在寻找那个。你已经很接近了。站在你的肩膀上,我能够解决一些问题。
    编辑(2015 年 5 月 9 日): 现在可以通过三冒号运算符 Drawdown() 调用函数 PerformanceAnalytics:::Drawdown() 。下面的代码经过编辑以反射(reflect)此更改。 编辑(2018 年 4 月 22 日): show_guide 已被弃用并替换为 show.legend

    require(xts)
    
    X.stock.rtns <- xts(rnorm(1000,0.00001,0.0003), Sys.Date()-(1000:1))
    Y.stock.rtns <- xts(rnorm(1000,0.00003,0.0004), Sys.Date()-(1000:1))
    Z.stock.rtns <- xts(rnorm(1000,0.00005,0.0005), Sys.Date()-(1000:1))
    rtn.obj <- merge(X.stock.rtns , Y.stock.rtns, Z.stock.rtns)
    colnames(rtn.obj) <- c("x","y","z")
    
    # advanced charts.PerforanceSummary based on ggplot
    gg.charts.PerformanceSummary <- function(rtn.obj, geometric = TRUE, main = "", plot = TRUE)
    {
    
        # load libraries
        suppressPackageStartupMessages(require(ggplot2))
        suppressPackageStartupMessages(require(scales))
        suppressPackageStartupMessages(require(reshape))
        suppressPackageStartupMessages(require(PerformanceAnalytics))
    
        # create function to clean returns if having NAs in data
        clean.rtn.xts <- function(univ.rtn.xts.obj,na.replace=0){
            univ.rtn.xts.obj[is.na(univ.rtn.xts.obj)]<- na.replace
            univ.rtn.xts.obj
        }
    
        # Create cumulative return function
        cum.rtn <- function(clean.xts.obj, g = TRUE)
        {
            x <- clean.xts.obj
            if(g == TRUE){y <- cumprod(x+1)-1} else {y <- cumsum(x)}
            y
        }
    
        # Create function to calculate drawdowns
        dd.xts <- function(clean.xts.obj, g = TRUE)
        {
            x <- clean.xts.obj
            if(g == TRUE){y <- PerformanceAnalytics:::Drawdowns(x)} else {y <- PerformanceAnalytics:::Drawdowns(x,geometric = FALSE)}
            y
        }
    
        # create a function to create a dataframe to be usable in ggplot to replicate charts.PerformanceSummary
        cps.df <- function(xts.obj,geometric)
        {
            x <- clean.rtn.xts(xts.obj)
            series.name <- colnames(xts.obj)[1]
            tmp <- cum.rtn(x,geometric)
            tmp$rtn <- x
            tmp$dd <- dd.xts(x,geometric)
            colnames(tmp) <- c("Index","Return","Drawdown") # names with space
            tmp.df <- as.data.frame(coredata(tmp))
            tmp.df$Date <- as.POSIXct(index(tmp))
            tmp.df.long <- melt(tmp.df,id.var="Date")
            tmp.df.long$asset <- rep(series.name,nrow(tmp.df.long))
            tmp.df.long
        }
    
        # A conditional statement altering the plot according to the number of assets
        if(ncol(rtn.obj)==1)
        {
            # using the cps.df function
            df <- cps.df(rtn.obj,geometric)
            # adding in a title string if need be
            if(main == ""){
                title.string <- paste("Asset Performance")
            } else {
                title.string <- main
            }
    
            gg.xts <- ggplot(df, aes_string( x = "Date", y = "value", group = "variable" )) +
                facet_grid(variable ~ ., scales = "free_y", space = "fixed") +
                geom_line(data = subset(df, variable == "Index")) +
                geom_bar(data = subset(df, variable == "Return"), stat = "identity") +
                geom_line(data = subset(df, variable == "Drawdown")) +
                geom_hline(yintercept = 0, size = 0.5, colour = "black") +
                ggtitle(title.string) +
                theme(axis.text.x = element_text(angle = 0, hjust = 1)) +
                scale_x_datetime(breaks = date_breaks("6 months"), labels = date_format("%m/%Y")) +
                ylab("") +
                xlab("")
    
        }
        else
        {
            # a few extra bits to deal with the added rtn columns
            no.of.assets <- ncol(rtn.obj)
            asset.names <- colnames(rtn.obj)
            df <- do.call(rbind,lapply(1:no.of.assets, function(x){cps.df(rtn.obj[,x],geometric)}))
            df$asset <- ordered(df$asset, levels=asset.names)
            if(main == ""){
                title.string <- paste("Asset",asset.names[1],asset.names[2],asset.names[3],"Performance")
            } else {
                title.string <- main
            }
    
            if(no.of.assets>5){legend.rows <- 5} else {legend.rows <- no.of.assets}
    
            gg.xts <- ggplot(df, aes_string(x = "Date", y = "value" )) +
    
                # panel layout
                facet_grid(variable~., scales = "free_y", space = "fixed", shrink = TRUE, drop = TRUE, margin =
                               , labeller = label_value) + # label_value is default
    
                # display points for Index and Drawdown, but not for Return
                geom_point(data = subset(df, variable == c("Index","Drawdown"))
                           , aes(colour = factor(asset), shape = factor(asset)), size = 1.2, show.legend = TRUE) +
    
                # manually select shape of geom_point
                scale_shape_manual(values = c(1,2,3)) +
    
                # line colours for the Index
                geom_line(data = subset(df, variable == "Index"), aes(colour = factor(asset)), show.legend = FALSE) +
    
                # bar colours for the Return
                geom_bar(data = subset(df,variable == "Return"), stat = "identity"
                         , aes(fill = factor(asset), colour = factor(asset)), position = "dodge", show.legend = FALSE) +
    
                # line colours for the Drawdown
                geom_line(data = subset(df, variable == "Drawdown"), aes(colour = factor(asset)), show.legend = FALSE) +
    
                # horizontal line to indicate zero values
                geom_hline(yintercept = 0, size = 0.5, colour = "black") +
    
                # horizontal ticks
                scale_x_datetime(breaks = date_breaks("6 months"), labels = date_format("%m/%Y")) +
    
                # main y-axis title
                ylab("") +
    
                # main x-axis title
                xlab("") +
    
                # main chart title
                ggtitle(title.string)
    
            # legend
    
            gglegend <- guide_legend(override.aes = list(size = 3))
    
            gg.xts <- gg.xts + guides(colour = gglegend, size = "none") +
    
                # gglegend <- guide_legend(override.aes = list(size = 3), direction = "horizontal") # direction overwritten by legend.box?
                # gg.xts <- gg.xts + guides(colour = gglegend, size = "none", shape = gglegend) + # Warning: "Duplicated override.aes is ignored"
    
                theme( legend.title = element_blank()
                       , legend.position = c(0,1)
                       , legend.justification = c(0,1)
                       , legend.background = element_rect(colour = 'grey')
                       , legend.key = element_rect(fill = "white", colour = "white")
                       , axis.text.x = element_text(angle = 0, hjust = 1)
                       , strip.background = element_rect(fill = "white")
                       , panel.background = element_rect(fill = "white", colour = "white")
                       , panel.grid.major = element_line(colour = "grey", size = 0.5)
                       , panel.grid.minor = element_line(colour = NA, size = 0.0)
                )
    
        }
    
        assign("gg.xts", gg.xts,envir=.GlobalEnv)
        if(plot == TRUE){
            plot(gg.xts)
        } else {}
    
    }
    
    # display chart
    gg.charts.PerformanceSummary(rtn.obj, geometric = TRUE)
    
    面板大小的控制在 facet_grid: facet_grid(variable ~ ., scales = "free_y", space = "fixed")。手册中解释了这些选项的作用,引用:

    更新:标签
    自定义标签可以通过以下功能获得:
    # create a function to store fancy axis labels
    
        my_labeller <- function(var, value){ # from the R Cookbook
            value <- as.character(value)
            if (var=="variable")
            {
                  value[value=="Index"] <- "Cumulative Returns"
                  value[value=="Return"] <- "Daily Returns"
                  value[value=="Drawdown"] <- "Drawdown"
            }
            return(value)
        }
    
    并将labeller选项设置为“labeller = my_labeller”
    更新:背景
    背景、网格线、颜色等的外观可以在 theme() 函数内进行控制:上面的代码已更新以反射(reflect)这些更改。
    r - ggplot 版本的 charts.PerformanceSummary-LMLPHP

    关于r - ggplot 版本的 charts.PerformanceSummary,我们在Stack Overflow上找到一个类似的问题:https://stackoverflow.com/questions/14817006/

    10-12 20:07