R/perryPlot.R

In perry: Resampling-Based Prediction Error Estimation for Regression Models

# --------------------------------------
# Author: Andreas Alfons
#         Erasmus Universiteit Rotterdam
# --------------------------------------

#' Plot resampling-based prediction error results
#'
#' Plot results of resampling-based prediction error measures.
#'
#' For objects with multiple columns of prediction error results, conditional
#' plots are produced.
#'
#' @param object,x  an object inheriting from class \code{"perry"} or
#' \code{"perrySelect"} that contains prediction error results, or an object of
#' class \code{"setupPerryPlot"} containing all necessary information for
#' plotting (as generated by \code{\link{setupPerryPlot}}).
#' @param which  a character string specifying the type of plot.  Possible
#' values are \code{"box"} to create a box plot, \code{"density"} to create a
#' smooth density plot, \code{"dot"} to create a dot plot, or \code{"line"} to
#' plot the (average) results for each model as a connected line (for objects
#' inheriting from class \code{"perrySelect"}).  Note that the first two plots
#' are only meaningful in case of repeated resampling.  The default is to use
#' \code{"box"} in case of repeated resampling and \code{"dot"} otherwise.
#' @param subset  a character, integer or logical vector indicating the subset
#' of models for which to plot the prediction error results.
#' @param select  a character, integer or logical vector indicating the columns
#' of prediction error results to be plotted.
#' @param seFactor  a numeric value giving the multiplication factor of the
#' standard error for displaying error bars in dot plots or line plots.  Error
#' bars in those plots can be suppressed by setting this to \code{NA}.
#' @param mapping  an aesthetic mapping to override the default behavior (see
#' \code{\link[ggplot2]{aes}} or \code{\link[ggplot2]{aes_string}}).
#' @param facets  a faceting formula to override the default behavior.  If
#' supplied, \code{\link[ggplot2]{facet_wrap}} or
#' \code{\link[ggplot2]{facet_grid}} is called depending on whether the formula
#' is one-sided or two-sided.
#' @param \dots  additional arguments to be passed down, eventually to
#' \code{\link[ggplot2]{geom_boxplot}}, \code{\link[ggplot2]{geom_density}},
#' \code{\link[ggplot2]{geom_pointrange}}, or \code{\link[ggplot2]{geom_line}}.
#'
#' @return
#' An object of class \code{"ggplot"} (see \code{\link[ggplot2]{ggplot}}).
#'
#' @note Duplicate indices in \code{subset} or \code{select} are removed such
#' that all models and prediction error results are unique.
#'
#' @author Andreas Alfons
#'
#' @seealso
#' \code{\link{setupPerryPlot}},
#'
#' \code{\link{perryFit}}, \code{\link{perrySelect}},
#' \code{\link{perryTuning}},
#'
#' \code{\link[ggplot2]{ggplot}}, \code{\link[ggplot2]{autoplot}},
#' \code{\link[graphics]{plot}}
#'
#' @example inst/doc/examples/example-perryPlot.R
#'
#' @keywords hplot
#'
#' @import ggplot2
#' @export

perryPlot <- function(object, ...) UseMethod("perryPlot")


#' @rdname perryPlot
#' @method perryPlot perry
#' @export

perryPlot.perry <- function(object, which = c("box", "density", "dot"),
                            select = NULL, seFactor = NA, ...) {
    # extract information for plotting
    setup <- setupPerryPlot(object, select = select, which = which,
                            seFactor = seFactor)
    # call method for object that contains all the necessary information
    perryPlot(setup, ...)
}


#' @rdname perryPlot
#' @method perryPlot perrySelect
#' @export

perryPlot.perrySelect <- function(object,
                                  which = c("box", "density", "dot", "line"),
                                  subset = NULL, select = NULL,
                                  seFactor = object$seFactor, ...) {
    # extract information for plotting
    setup <- setupPerryPlot(object, subset = subset, select = select,
                            which = which, seFactor = seFactor)
    # call method for object that contains all the necessary information
    perryPlot(setup, ...)
}


#' @rdname perryPlot
#' @method perryPlot setupPerryPlot
#' @export

perryPlot.setupPerryPlot <- function(object, mapping = object$mapping,
                                     facets = object$facets, ...) {
    # initializations
    which <- object$which
    # call function for selected plot
    if (which == "box") {
        boxPlot(object, mapping = mapping, facets = facets, ...)
    } else if(which == "density") {
        densityPlot(object, mapping = mapping, facets = facets, ...)
    } else if(which == "line") {
        linePlot(object, mapping = mapping, facets = facets, ...)
    } else dotPlot(object, mapping = mapping, facets = facets, ...)
}


#' @rdname perryPlot
#' @method autoplot perry
#' @export

autoplot.perry <- function(object, ...) perryPlot(object, ...)


#' @rdname perryPlot
#' @method autoplot perrySelect
#' @export

autoplot.perrySelect <- function(object, ...) perryPlot(object, ...)


#' @rdname perryPlot
#' @method plot perry
#' @export

plot.perry <- function(x, ...) perryPlot(x, ...)


#' @rdname perryPlot
#' @method plot perrySelect
#' @export

plot.perrySelect <- function(x, ...) perryPlot(x, ...)

# ----------

boxPlot <- function(object, mapping = object$mapping,
                    facets = object$facets, ...) {
    # generate plot
    p <- ggplot(object$data, mapping) + geom_boxplot(...) +
        labs(x = NULL, y = "Prediction error")
    if (!is.null(facets)) {
        # split plot into different panels
        if (length(facets) == 2) p <- p + facet_wrap(facets)
        else p <- p + facet_grid(facets)
    }
    # return plot
    p
}

# ----------

densityPlot <- function(object, mapping = object$mapping,
                        facets = object$facets, ...) {
    # initializations
    data <- object$data
    fits <- data[, "Fit"]
    # generate plot
    p <- ggplot(data, mapping) + geom_density(...) +
        labs(x = "Prediction error", y = NULL)
    if (is.numeric(fits)) {
        guide <- if (is.integer(fits)) "legend" else "colorbar"
        p <- p + scale_color_continuous(breaks = unique(fits), guide = guide)
    }
    if (!is.null(facets)) {
        # split plot into different panels
        if (length(facets) == 2) p <- p + facet_wrap(facets)
        else p <- p + facet_grid(facets)
    }
    # return plot
    p
}

# ----------

dotPlot <- function(object, mapping = object$mapping,
                    facets = object$facets, ...) {
    # generate plot
    p <- ggplot(object$data, mapping) +
        geom_pointrange(...) +
        labs(x = NULL, y = "Prediction error")
    if (!is.null(facets)) {
        # split plot into different panels
        if (length(facets) == 2) p <- p + facet_wrap(facets)
        else p <- p + facet_grid(facets)
    }
    # return plot
    p
}

# ----------

linePlot <- function(object, mapping = object$mapping, facets = object$facets, ...) {
    # generate plot
    p <- ggplot(object$data, mapping) +
        local_geom_line(...) +
        geom_pointrange(...) +
        labs(x = NULL, y = "Prediction error")
    if (!is.null(facets)) {
        # split plot into different panels
        if (length(facets) == 2) p <- p + facet_wrap(facets)
        else p <- p + facet_grid(facets)
    }
    p
}


## utility functions

# local geom to avoid warning
local_geom_line <- function(..., fatten) {
    geom_line(...)
}