versione ggplot di charts.PerformanceSummary

Question

Vorrei creare una "versione ggplot" della funzionalità di base di charts.PerformanceSummary disponibile nel pacchetto PerformanceAnalytics, poiché penso che ggplot sia generalmente più bello e teoricamente più potente in termini di modifica del Immagine. Ho ragionevolmente vicino ma ho alcuni problemi su cui vorrei un po 'di aiuto. Vale a dire:

1. riducendo la quantità di spazio che la leggenda prende, diventa orrendo/brutto quando si hanno più di 10 linee su di esso ... (solo il colore della linea e il nome è sufficiente)
2. Aumentare la dimensione della faccetta Daily_Returns corrispondente a quella dei grafici.PerformanceSummary in PerformanceAnalytics
3. Avere un'opzione che specifica quale risorsa mostrare nella serie di resi giornalieri nella faccetta Daily_Returns, invece di utilizzare sempre la prima colonna, che è ciò che accade in charts.PerformanceSummary

Se ci sono modi migliori per fare questo potenzialmente usando gridExtra piuttosto che faccette ... Non sono contrario alle persone che mi mostrano come sarebbe meglio ...

Il problema qui è l'estetica, e il potenziale facile di manipolazione suppongo, visto che PerformanceAnalytics ha già un buon esempio di lavoro, voglio solo renderlo più bello/più professionale ...

Oltre a questo per i punti bonus, vorrei poter mostrare alcune statistiche sulle prestazioni associate con esso da qualche parte sopra o sotto o sul lato del grafico per ogni risorsa ... non troppo sicuro di dove sarebbe meglio mostrare o visualizzare queste informazioni.

Inoltre, non sono contrario a persone che suggeriscono parti che puliscono il mio codice se hanno suggerimenti per questo.

Ecco il mio esempio riproducibile ...

Prima generare dati di ritorno:

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") 

vorrei replicare l'immagine dal risultato di:

require(PerformanceAnalytics) 
charts.PerformanceSummary(rtn.obj, geometric=TRUE) 

Questo è il mio tentativo finora ...

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

Per la dimensione della leggenda, vedi? Tema. La maggior parte degli aspetti della legenda può essere regolata da lì ... Quello che vuoi regolare è legend.key.size Suppongo, oltre a legend.background di rimuovere la casella attorno ad ogni leggenda ...

La dimensione di ogni pannello in sfaccettatura è un po 'più complicato. Ho un hack che ti permette di specificare la dimensione relativa di ogni pannello quando si chiama facet_grid, ma richiede l'installazione dal sorgente ecc ... Una soluzione migliore sarebbe convertire la trama in un oggetto Gtable e modificarla ... assumendo la trama si chiama p:

require(gtable) 
require(grid) 

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

grid.newpage() 
grid.draw(pTable) 

Questo renderà l'altezza del pannello superiore raddoppiare la dimensione di ciascuno degli altri pannelli ...Il motivo per cui è pTable $ heights [[4]] e non pTable $ heights [[1]] è che i pannelli di sfaccettatura non sono i soliti top nella trama.

mi asterrò da essere più specifico di questo, come sarà meglio serviti da esplorare le proprietà di gtable te stesso (e perché non ho tempo)

migliore

Thomas

Answer 2

Stavo cercando proprio questo. Sei molto vicino. In piedi sulle tue spalle, sono stato in grado di risolvere alcuni dei problemi. Ma visto che sono nuovo di R, ggplot, e tutto il resto, il mio contributo è modesto.

Edit (9 maggio 2015): La funzione Drawdown() può ora essere chiamato tramite l'operatore triple-colon, PerformanceAnalytics:::Drawdown(). Il codice di seguito è stato modificato per riflettere questo cambiamento.

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) 

controllo delle dimensioni dei pannelli è all'interno facet_grid: facet_grid (variabile ~, scale = "free_y", spazio = "fisso".). Quello che queste opzioni non è spiegato nel manuale, citazione:

scale: sono scale comuni in tutti gli aspetti (l'impostazione predefinita, "fisso"), o se invece variano tra le righe ("free_x"), colonne ("free_y") o entrambe le righe e le colonne ("gratuito")

spazio: Se "corretto", l'impostazione predefinita, tutti i pannelli hanno le stesse dimensioni. Se "free_y" la loro altezza sarà proporzionale alla lunghezza della scala y; se "free_x" la loro larghezza sarà proporzionale alla lunghezza della scala x; oppure se "libero" sia l'altezza che la larghezza varieranno. Questa impostazione non ha alcun effetto a meno che anche le scale appropriate non cambino.

Ho ottimizzato il secondo grafico, il primo può essere eseguito in modo simile.

Aggiornamento: Contrassegni

etichette personalizzate possono essere ottenuti con la seguente funzione:

# 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) 
    } 

e impostando l'opzione etichettatrice a "etichettatrice = my_labeller"

Aggiornamento: sfondo

L'aspetto di t lo sfondo, le linee della griglia, i colori, ecc. possono essere controllati dalla funzione theme(). Ecco un esempio con uno sfondo bianco per i 3 assi del tracciato, uno sfondo bianco per l'area del tracciato e linee grigie della griglia. Può essere cambiato tutto piuttosto facilmente con il modello sottostante:

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) 
     )