那些遇到过的问题

ggplot版本的chart.PerformanceSummary

h.l*_*l.m 7 r ggplot2 performanceanalytics

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

  1. 减少图例占用的空间量,当它上面有10行以上时会变得可怕/丑陋...(只是线条颜色和名称就足够了)
  2. 增加Daily_Returns facet的大小以匹配chart.PerformanceSummary的大小 PerformanceAnalytics
  3. 有一个选项可以指定在Daily_Returns facet的每日回复系列中显示哪个资产,而不是总是使用第一列,这比在 charts.PerformanceSummary

如果有更好的方法来做这个可能使用gridExtra而不是方面...我不会对那些让我看起来会更好看的人感到不利...

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

除了这个奖励积分之外,我希望能够在每个资产的图表一侧或下方某处显示与之相关的一些性能统计数据......不太确定哪里最好显示或显示此信息.

此外,如果他们对此提出建议,我并不反对人们建议清理我的代码的部分.

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

首先生成返回数据:

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")
Run Code Online (Sandbox Code Playgroud)

我想复制以下结果的图像:

require(PerformanceAnalytics)
charts.PerformanceSummary(rtn.obj, geometric=TRUE)
Run Code Online (Sandbox Code Playgroud)

目标

这是我到目前为止的尝试......

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)
Run Code Online (Sandbox Code Playgroud)

结果

Pat*_*ckT 12

我一直在找那个.你非常接近.站在你的肩膀上,我能够解决一些问题.

编辑(2015年5月9日):Drawdown()现在可以通过三冒号运算符调用该函数PerformanceAnalytics:::Drawdown().编辑以下代码以反映此更改.编辑(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)
Run Code Online (Sandbox Code Playgroud)

控制面板的大小在facet_grid:facet_grid(变量〜.,scales ="free_y",space ="fixed")内.这些选项的作用在手册中有解释,引用:

尺度:尺度是否在所有方面共享(默认,"固定"),或者它们是否在行("free_x"),列("free_y")或行和列("自由")之间变化

space:如果是"fixed",默认情况下,所有面板都有相同的大小.如果"free_y",它们的高度将与y标度的长度成比例; 如果"free_x",它们的宽度将与x标度的长度成比例; 或者如果"自由",高度和宽度都会有所不同.除非适当的比例也有所不同,否则此设置无效.

更新:标签

可以使用以下功能获得自定义标签:

# 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)
    }
Run Code Online (Sandbox Code Playgroud)

并将labeller选项设置为"labeller = my_labeller"

更新:背景

可以在theme()函数内控制背景,网格线,颜色等的外观:上面的代码已经更新以反映这些变化.

在此输入图像描述

Tho*_*P85 1

有关图例的大小，请参阅 ?theme。图例的大多数方面都可以通过那里进行调整...我猜你想要调整的是 legend.key.size ，以及 legend.background 以删除每个图例周围的框...

刻面中每个面板的尺寸有点复杂。我有一个黑客，可以让您在调用facet_grid时指定每个面板的相对大小，但它需要从源安装等...更好的解决方案是将您的图转换为gtable对象并修改它...假设您的图称为 p：

require(gtable)
require(grid)

pTable <- ggplot_gtable(ggplot_build(p))
pTable$heights[[4]] <- unit(2, 'null')

grid.newpage()
grid.draw(pTable)
Run Code Online (Sandbox Code Playgroud)

这将使顶部面板的高度是其他每个面板大小的两倍...它是 pTable$heights[[4]] 而不是 pTable$heights[[1]] 的原因是分面面板不是情节中最重要的部分。

我不会比这更具体，因为你自己探索 gtable 的属性会得到最好的服务（而且因为我没有时间）

最好的

托马斯

归档时间：

查看次数：

3904 次

最近记录：

7 年，6 月 前
相关归档
如何从源代码安装R软件包？ 371
在Mac上安装R - 警告消息:使用"C"设置LC_CTYPE失败 201
确定对象的内存使用情况？ 128
在RMarkdown中更改块背景颜色 32
ggplot2的默认字体是什么 29
dplyr rename - 错误:`new_name` = old_name必须是符号或字符串,而不是公式 19
TwitteR,ROAuth和Windows:注册正常,但证书验证失败 15
r markdown - 使用新行格式化代码块中的文本 13
在图例中为多个图层显示正确的颜色 2
ggplot使用purrr map()绘制具有多个y的相同x 2
难疑归档
如何丢弃Git中的未分级更改？ 4562
在JavaScript中创建GUID/UUID？ 3915
在shell中,"2>&1"是什么意思？ 2121
什么是反思,为什么它有用？ 2011
使用pip升级所有包 1859
如何在Javascript中的数组开头添加新的数组元素？ 1476
如何删除导出的环境变量？ 1439
如何在Xcode 4中"添加现有框架"？ 1426
什么是C++ 11中的lambda表达式？ 1408
"this"关键字如何运作？ 1243