ggplot version of charts.PerformanceSummary

Question

Я хотел бы сделать «версию ggplot» базовой функциональности charts.PerformanceSummary, которая доступна в пакете PerformanceAnalytics, так как я думаю, что ggplot обычно красивее и теоретически более мощный с точки зрения редактирования образ. У меня достаточно близкие, но у меня есть несколько вопросов, на которые мне хотелось бы помочь. А именно:

1. уменьшая объем пространства, что легенда берет вверх, это становится ужасающим/некрасиво, имея более чем 10 строк на нем ... (только цвет линии и название достаточно)
2. Увеличение размер арифметики Daily_Returns в соответствии с диаграммой charts.PerformanceSummary в PerformanceAnalytics
3. Есть опция, которая указывает, какой актив показывать в ежедневной строке возврата в факеле Daily_Returns, а не всегда использовать первый столбец, который является чем то, что происходит в 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") 

Я хотел бы повторить изображение из результата:

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) 

Answer 1

Для размера легенды см? Тему. Большинство аспектов легенды можно отрегулировать с помощью там ... То, что вы хотите настроить, - legend.key.size Я думаю, а также legend.background, чтобы удалить поле вокруг каждой легенды ...

Размер каждая панель в огранке немного сложнее. У меня есть хак, который позволяет указать относительный размер каждой панели при вызове facet_grid, но для этого требуется установка из источника и т. Д. Лучшим решением было бы преобразовать ваш сюжет в объект gtable и изменить его ... при условии, что ваш сюжет называются р:

require(gtable) 
require(grid) 

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

grid.newpage() 
grid.draw(pTable) 

Это сделает высоту верхней панели двойного размера каждого из других панелей ...Причина, по которой это pTable $ height [[4]], а не pTable $ height [[1]], заключается в том, что граненые панели не являются верхними гнетами на графике.

я воздержусь от того, более конкретно, чем это, как вы будете лучше всего, исследуя свойства gtable себя (и потому, что у меня нет времени)

лучшего

Томас

Answer 2

Я искал именно это. Вы довольно близко. Стоя на плечах, я смог исправить некоторые проблемы. Но поскольку я новичок в R, ggplot и все такое, мой вклад скромный.

Редактировать (9 мая 2015): Функция Drawdown() может теперь быть вызван с помощью оператора тройной толстой кишки, PerformanceAnalytics:::Drawdown(). Код, приведенный ниже, был отредактирован, чтобы отразить это изменение.

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_guide = 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_guide = 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_guide = FALSE) + 

     # line colours for the Drawdown 
     geom_line(data = subset(df, variable == "Drawdown"), aes(colour = factor(asset)), show_guide = 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() 
      , legend.box = "horizontal" # not working? 
      , axis.text.x = element_text(angle = 0, hjust = 1) 
      ) 

} 

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 (переменная ~, весы = "free_y", пространство = "фиксированный".). То, что эти варианты этого объясняются в руководстве, цитата:

весы: весы, общие для всех граней (по умолчанию, «фиксированное»), или же они различаются по строкам («free_x»), колонны («free_y») или обе строки и столбцы («бесплатно»)

space: Если «фиксированная», по умолчанию все панели имеют одинаковый размер. Если «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) 
    } 

и установки опции этикетировочные к "этикетировочные = my_labeller"

Обновление: фон

Появление t его фон, линии сетки, цвета и т. д. можно контролировать из функции theme(). Вот пример с белым фоном для трех сюжетных осей, белый фон для участка графика и серых линий сетки. Это может все изменить довольно легко с помощью следующей матрицы:

theme(legend.title = element_blank() 
     , legend.position = c(0,1) 
     , legend.justification = c(0,1) 
     , legend.background = element_rect() 
     #, legend.key = element_rect(fill="white",colour="white")# added as afterthought 
     , legend.box = "horizontal" # not working? 
     , axis.text.x = element_text(angle = 0, hjust = 1) 
     #, axis.title.y = element_text(size=2,colour="black") 
     , 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) 
     )