# lattice.pbo.R
#' Writes grid text to a default predetermined location.
#' @note Meant for internal use only.
#' @param p an object of class \code{pbo} as returned by \code{\link[pbo]{pbo}}.
#' @import grid
pbo_show_config <- function(p) {
grid.text(label=p$test_config,
x = unit(1,"npc") - unit(3,"mm"),
y = unit(1,"npc") - unit(3,"mm"),
just="right")
}
#' @title PBO rank logits histogram.
#' @description Draws an annotated histogram of PBO rank logits.
#' @details Uses \pkg{lattice} function \code{\link[lattice]{histogram}},
#' \code{\link[lattice]{densityplot}}, and
#' \code{\link[lattice]{panel.abline}} panels together with
#' class-specific annotations.
#' @param x an object of class \code{pbo} as returned by \code{\link[pbo]{pbo}}.
#' @param data should not be used
#' @param show_pbo whether to show the PBO value annotation,
#' default TRUE
#' @param show_regions whether to show the overfit region annotations,
#' default TRUE
#' @param show_config whether to show the study dimension annotations,
#' default TRUE
#' @param col_bar histogram bar fill color passed to histogram panel
#' @param col_line density plot line color passed to density plot panel
#' @param ... other parameters passed to \code{\link[lattice]{histogram}},
#' \code{\link[lattice]{densityplot}}, or \code{\link[lattice]{panel.abline}}.
#' @seealso pbo, dotplot.pbo, xyplot.pbo
#' @importFrom lattice histogram
#' @importFrom lattice panel.histogram
#' @importFrom lattice panel.densityplot
#' @importFrom lattice panel.abline
#' @export
histogram.pbo <- function(x,
data=NULL,
show_pbo=TRUE,
show_regions=TRUE,
show_config=TRUE,
col_bar="#cc99cc",
col_line="#3366cc",
...)
{
# advise ignoring data
if (!is.null(match.call()$data))
warning("explicit 'data' specification ignored; using 'pbo' object")
# class reference for use within panels
p <- x
# plot rank logit with PBO annotation
histogram(p$lambda,
xlim=c(-p$inf_sub,p$inf_sub),
xlab=expression(lambda[c]),
panel = function(x, ...){
panel.histogram(x, col=col_bar,...)
panel.densityplot(x, col=col_line, ...)
panel.abline(v=0,lty=3,...)
if (show_pbo) {
xa <- unit(0, "npc") + unit(2, "mm")
ya <- unit(1, "npc") - unit(3, "mm")
grid.text(label = bquote(PBO == .(round(p$phi,digits=3))),
x = xa,
y = ya,
just = "left")
}
if (show_config)
pbo_show_config(p)
if (show_regions) {
ya <- unit(1, "npc") - unit(3, "mm")
grid.text(label = "Less overfit",
x = unit(0.5,"npc") + unit(2,"mm"),
y=ya,
just="left")
grid.text(label = "More overfit",
x = unit(0.5,"npc") - unit(2,"mm"),
y=ya,
just="right")
}
},
...
)
}
#' @title PBO in-sample selection dot plot.
#' @description Draws an annotated dot plot of study selection sorted
#' by in-sample selection frequency.
#' @param x a \code{pbo} object as returned by \code{\link[pbo]{pbo}}.
#' @param data should not be used
#' @param main plot title, default computed internally,
#' passed to \code{\link[lattice]{dotplot}}.
#' @param xlab x-axis label with default,
#' passed to \code{\link[lattice]{dotplot}}.
#' @param ylab y-axis label with default,
#' passed to \code{\link[lattice]{dotplot}}.
#' @param show_config whether to show the study dimension annotations,
#' default TRUE
#' @param show_grid whether to show the grid panel, default TRUE
#' @param sel_threshold the minimum in-sample frequency subsetting threshold,
#' default 0; selection frequencies at or below this value will be omitted
#' @param ... other parameters as passed to \code{\link[lattice]{dotplot}}.
#' @keywords pbo backtest overfitting
#' @importFrom lattice dotplot
#' @importFrom lattice panel.xyplot panel.grid
#' @importFrom stats reorder
#' @export
#' @seealso pbo, histogram.pbo, xyplot.pbo
dotplot.pbo <- function(x,
data=NULL,
main,
xlab="Sorted Study Number (N)",
ylab="IS Selection Frequency",
show_config=TRUE,
show_grid=TRUE,
sel_threshold=0,
...)
{
# advise ignoring data
if (!is.null(match.call()$data))
warning("explicit 'data' specification ignored; using 'pbo' object")
p <- x
# x <- p$results
Freq <- NULL # only to appease check
ns <- as.integer(x$results[,'n*']) # n_star result in-sample
tns <- data.frame(table(ns)) # for frequency counts
tns$ns <- stats::reorder(tns$ns,-tns$Freq) # sorted by decreasing frequency
if (missing(main))
main=paste("IS Study Selection (Frequency > ",sel_threshold,")",sep='')
dotplot(Freq ~ ns,
data=tns,
subset=Freq>sel_threshold,
xlab=xlab,
ylab=ylab,
main=main,
panel = function(x,...) {
panel.xyplot(x,...)
if (show_grid)
panel.grid(-1,-1,...)
if (show_config)
pbo_show_config(p)
},
...
)
}
#' @title PBO xy-plots
#' @description Draws an annotated plot of performance degradation and
#' probability of loss.
#' @details Provides several variations of xy-plots suitable for presentation
#' of PBO analysis results. Use the \code{plotType} argument to indicate
#' which variation or result to plot:
#' \itemize{
#' \item The \code{cscv} type shows in-sample
#' and out-of-sample results by CSCV iteration case (default).
#' \item The \code{degradation} type shows the performance degradation regression
#' fit results and the probability of loss.
#' \item The \code{dominance} type shows the results of the first-order and
#' second-order stochastic dominance analysis using two axes.
#' \item The \code{pairs} type shows the in-sample and out-of-sample
#' case selections.
#' \item The \code{ranks} type shows the sorted performance ranks results.
#' \item The \code{selection} type shows the case selection frequencies.
#' }
#' @param x a \code{pbo} object as returned by \code{\link{pbo}}.
#' @param data should not be used
#' @param plotType one of \code{cscv}, \code{degradation}, \code{dominance},
#' \code{pairs}, \code{ranks} or \code{selection}.
#' @param col_bar histogram bar fill color
#' @param col_line density plot line color
#' @param col_sd1 color of two first-order stochastic dominance lines
#' @param col_sd2 color of the single second-order stochastic dominance line
#' @param xlab x-axis label, default computed if not provided
#' @param ylab y-axis label, default computed if not provided
#' @param main plot title, default computed if not provided
#' @param lwd line width, default 1, passed to panels and legends
#' @param lty_sd line type array for stochastic dominance plot,
#' e.g. c(2,3,5)
#' @param ylab_left dominance plot left-hand axis label
#' @param ylab_right dominance plot right-hand axis label
#' @param increment stochastic dominance distribution generator increment,
#' e.g. 0.1 steps
#' @param osr_threshold out-of-sample rank threshold for filtering, default 0
#' @param sel_threshold selection frequency threshold for filtering, default 0
#' @param show_eqn whether to show the line equation annotation, default TRUE
#' @param show_threshold whether to show the probability of loss annotation,
#' default TRUE
#' @param show_config whether to show the study dimension annotations,
#' default TRUE
#' @param show_grid whether to show the panel grid,
#' default TRUE
#' @param show_prob whether to show the probability value in dominance plot,
#' default TRUE
#' @param show_rug whether to show scatter rugs near the axes,
#' default TRUE
#' @param ... other parameters passed to \code{\link[lattice]{xyplot}}
#' or its panels
#' @importFrom lattice xyplot
#' @importFrom lattice panel.xyplot panel.rug panel.grid
#' @importFrom lattice panel.lmline panel.abline
#' @importFrom latticeExtra doubleYScale
#' @importFrom stats ecdf reorder
#' @export
#' @keywords PBO CSCV
#' @seealso pbo, histogram.pbo, xyplot.pbo
xyplot.pbo <- function(x,
data=NULL,
plotType="cscv",
show_eqn=TRUE,
show_threshold=TRUE,
show_config=TRUE,
show_rug=TRUE,
show_prob=TRUE,
show_grid=TRUE,
increment=0.01,
osr_threshold=0,
sel_threshold=0,
xlab,
ylab,
main,
lwd=1,
ylab_left,
ylab_right,
col_bar,
col_line,
col_sd1="#3366cc",
col_sd2="#339999",
lty_sd=c(1,2,4),
...)
{
# confirm plot type specified
ptypes = c('cscv','degradation','dominance','pairs','ranks','selection')
if ( ! plotType %in% ptypes )
stop(paste("xyplot with 'pbo' object argument 'plotType' must be one of",
toString(ptypes)))
# advise ignoring data
if (!is.null(match.call()$data))
warning("xyplot explicit 'data' specification ignored; using 'pbo' object")
# reference to object for use within panels
p <- x
# cscv plot
if (plotType == "cscv") {
if (missing(xlab))
xlab='CSCV Case'
if (missing(ylab))
ylab='Selected Study (N)'
if (missing(main))
main=bquote(paste("IS/OOS Study Selection by CSCV Case (OOS Rank > ",
.(osr_threshold),
')',
sep='' ))
osr <- NULL # only to appease check
y <- data.frame(cbind(nis=as.numeric(p$results[,'n*']),
noos=as.numeric(p$results[,'n_max_oos']),
osr=as.numeric(p$results[,'os_rank'])))
rv = xyplot(noos + nis ~ 1:nrow(y),
data=y,
subset=osr>osr_threshold,
main=main,
xlab=xlab,
ylab=ylab,
lwd=lwd,
panel = function(x,...) {
panel.xyplot(x,...)
if ( show_grid )
panel.grid(-1,-1,...)
if ( show_rug )
panel.rug(x,...)
if (show_config)
pbo_show_config(p)
},
...
)
}
# performance degradation plot
if (plotType == "degradation") {
if (missing(main))
main="OOS Performance Degradation"
if (missing(xlab))
xlab="R (IS)"
if (missing(ylab))
ylab="R (OOS)"
if (missing(col_bar))
col_bar="#cc99cc"
if (missing(col_line))
col_line="#3366cc"
# plot Rn pairs
cloud_span <- c(signif(min(p$rn_pairs),-3),
signif(max(p$rn_pairs),3)) # axis range
rv = xyplot(p$rn_pairs$Rbn ~ p$rn_pairs$Rn,
main = main,
xlab = xlab,
ylab = ylab,
xlim = cloud_span,
ylim = cloud_span,
lwd = lwd,
panel = function(x, ...){
panel.xyplot(x,col=col_bar,...)
panel.lmline(x,col=col_line,...)
panel.abline(v=p$threshold,type="l",lty=3)
panel.abline(h=p$threshold,type="l",lty=3)
if ( show_rug ) {
panel.rug(x,col=col_bar,...)
}
ya <- unit(1, "npc") - unit(3, "mm")
if ( show_eqn ) {
grid.text(label = bquote(R_OOS == .(p$intercept) (R_IS) + .(p$slope) + err ~~ AdjR^2 == .(p$ar2)),
x = unit(0, "npc") + unit(3, "mm"),
y = ya,
just = "left",
gp=gpar(col=col_line))
}
if (show_config)
pbo_show_config(p)
if (show_threshold) {
if ( p$threshold == 1 ) { # ugly but ifelse won't work on bquote
grid.text(label = bquote(P(R_OOS<1) == .(p$below_threshold)),
x = unit(1, "npc") - unit(3, "mm"),
y = ya - unit(10,"mm"),
just = "right",
gp=gpar(col=col_bar))
} else {
grid.text(label = bquote(P(R_OOS<0) == .(p$below_threshold)),
x = unit(1, "npc") - unit(3, "mm"),
y = ya - unit(10,"mm"),
just = "right",
gp=gpar(col=col_bar))
}
}
},
...
)
}
# stochastic dominance plot
if ( plotType == "dominance") {
if (missing(main))
main="Stochastic Dominance"
if (missing(ylab_left))
ylab_left="Frequency"
if (missing(ylab_right))
ylab_right="2nd Ord. Stochastic Dominance"
# uses n* items from R-bar for one line, and all n items from R-bar for the other line
# create cumulative distribution functions for each data set,
# then generate samples to plot
y <- seq(min(p$rn_pairs$Rbn),
max(p$rn_pairs$Rbn),
increment) # reasonable R range for evaluation
erbn <- stats::ecdf(p$rn_pairs$Rbn) # optimized
erb <- stats::ecdf(sapply(1:ncol(p$combos),
function(i) p$results[[i,2]])) # non-optimized (all)
sorted <- data.frame(cbind(sort(erbn(y)),sort(erb(y))))
sorted$sd2 <- sorted$X2 - sorted$X1
colnames(sorted) <- c("Rbn","Rb","SD2")
colors = c(col_sd1,col_sd1,col_sd2)
x1 = xyplot(Rbn + Rb ~ y,
data = sorted,
type="l",
lty=lty_sd,
lwd=lwd,
col=colors,
main=main,
ylab=ylab_left,
xlab=expression(bar(R)[n^textstyle("*")] ~~ plain(vs.) ~~ bar(R)),
key=list(columns=3,
lines=list(col=colors,
lty=lty_sd,
lwd=lwd),
text=list(names=c("Optimized (L)",
"Non-Optimized (L)",
"SD2 (R)"))
),
panel = function(x, ...){
panel.xyplot(x,...)
panel.abline(v=p$threshold,type="l",lty=3)
if (show_grid)
panel.grid(-1,-1)
if (show_prob) {
grid.text(label = expression(paste(italic(Prob),
group("[",bar(R)[n^textstyle("*")] >= x,"]"),
" > ",
italic(Prob),
group("[",bar(R) >= x,"]"))),
x = unit(0, "npc") + unit(3, "mm"),
y = unit(0, "npc") + unit(3, "mm"),
just = "left"
)
}
if (show_config)
pbo_show_config(p)
},
...
)
x2 = xyplot(SD2 ~ y,
data=sorted,
type="l",
lwd=lwd,
lty=ifelse(length(lty_sd>2),lty_sd[3],lty_sd),
col=colors[3],
ylab=ylab_right,
panel = function(x, ...){
panel.xyplot(x,...)
panel.abline(h=0,type="l",lty=3)
grid.text(label = expression(italic(SD2) >= 0),
x = unit(1, "npc") - unit(3, "mm"),
y = unit(0, "npc") + unit(3, "mm"),
just = "right"
)
},
...
)
rv = latticeExtra::doubleYScale(x1,
x2,
add.ylab2=TRUE,
use.style=FALSE
)
}
if (plotType == "pairs") {
if (missing(xlab))
xlab='IS Selection (N)'
if (missing(ylab))
ylab='OOS Counterpart Selection (N)'
if (missing(main))
main= bquote(paste("IS/OOS Study Selection Performance (OOS Rank > ",
.(osr_threshold),
')',
sep='' ))
# x <- p$results
y <- data.frame(cbind(nis=as.numeric(p$results[,'n*']),
noos=as.numeric(p$results[,'n_max_oos']),
osr=as.numeric(p$results[,'os_rank'])))
rv = xyplot(noos ~ nis,
data=y,
subset=osr>osr_threshold,
xlab=xlab,
ylab=ylab,
main=main,
lwd=lwd,
panel = function(x,...) {
panel.xyplot(x,...)
if ( show_grid )
panel.grid(-1,-1,...)
if ( show_rug )
panel.rug(x,...)
if (show_config)
pbo_show_config(p)
},
...
)
}
if (plotType == "ranks") {
if (missing(xlab))
xlab='Selected IS Study (N)'
if (missing(ylab))
ylab='OOS Rank'
if (missing(main))
main=bquote(paste("Selected IS Study Performance OOS (OOS Rank > ",
.(osr_threshold),
')',
sep='' ))
# x <- p$results
y <- data.frame(cbind(nis=as.numeric(p$results[,'n*']),
noos=as.numeric(p$results[,'n_max_oos']),
osr=as.numeric(p$results[,'os_rank'])))
rv = xyplot(osr ~ nis,
data=y,
subset=osr>osr_threshold,
xlab=xlab,
ylab=ylab,
lwd=lwd,
main=main,
horizontal=FALSE,
panel = function(x,...) {
panel.xyplot(x,...)
if ( show_grid )
panel.grid(-1,-1,...)
if ( show_rug )
panel.rug(x,...)
if (show_config)
pbo_show_config(p)
},
...
)
}
if ( plotType == "selection") {
if (missing(xlab))
xlab="Sorted Study Number (N)"
if (missing(ylab))
ylab="IS Selection Frequency"
if (missing(main))
main= bquote(paste("IS Study Selection (Frequency > ",
.(sel_threshold),
')',
sep='' ))
# x <- p$results
Freq <- NULL # only to appease check
ns <- as.integer(p$results[,'n*']) # n_star result in-sample
tns <- data.frame(table(ns)) # for frequency counts
tns$ns <- stats::reorder(tns$ns,-tns$Freq) # sorted by decreasing frequency
rv = xyplot(Freq ~ ns,
data=tns,
subset=Freq>sel_threshold,
xlab=xlab,
ylab=ylab,
main=main,
horizontal=FALSE,
panel = function(x,...) {
panel.xyplot(x,...)
if (show_grid)
panel.grid(-1,-1,...)
if (show_rug)
panel.rug(x=NULL,...) # show only y-axis rug
if (show_config)
pbo_show_config(p)
},
...
)
}
# returns the plot, flushing the graphics
rv
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.