R/perry-deprecated.R

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

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


#' Deprecated functions in package \pkg{perry}
#'
#' These functions are provided for compatibility with older versions only, and
#' may be defunct as soon as the next release.
#'
#' The \code{fortify} methods extract all necessary information for plotting
#' from resampling-based prediction error results and store it in a data frame.
#'
#' The default method of \code{perryPlot} creates the corresponding plot from
#' the data frame returned by \code{fortify}.
#'
#' @name perry-deprecated
#'
#' @param model  an object inheriting from class \code{"perry"} or
#' \code{"perrySelect"} that contains prediction error results.
#' @param data  currently ignored.
#' @param subset  a character, integer or logical vector indicating the subset
#' of models to be converted.
#' @param select  a character, integer or logical vector indicating the columns
#' of prediction error results to be converted.
#' @param reps  a logical indicating whether to convert the results from all
#' replications (\code{TRUE}) or the aggregated results (\code{FALSE}).  The
#' former is suitable for box plots or smooth density plots, while the latter
#' is suitable for dot plots or line plots (see \code{\link{perryPlot}}).
#' @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 object  an object inheriting from class \code{"perry"} or
#' \code{"perrySelect"} that contains prediction error results, or a data frame
#' containing all necessary information for plotting (as generated by the
#' corresponding \code{\link[=fortify.perry]{fortify}} method).
#' @param method  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.  In
#' any case, partial string matching allows supply abbreviations of the
#' accepted values.
#' @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  for the \code{"perryTuning"} method of \code{fortify},
#' additional arguments to be passed down to its \code{"perrySelect"}
#' method.  For the other methods of \code{fortify}, additional arguments are
#' currently ignored.  For the default method of \code{perryPlot}, additional
#' arguments to be passed down to \code{\link[ggplot2]{geom_boxplot}},
#' \code{\link[ggplot2]{geom_density}}, \code{\link[ggplot2]{geom_pointrange}}
#' or \code{\link[ggplot2]{geom_line}}.
#'
#' @return  The \code{fortify} methods return a data frame containing the
#' columns listed below, as well as additional information stored in the
#' attribute \code{"facets"} (default faceting formula for the plots).
#' \describe{
#'   \item{\code{Fit}}{a vector or factor containing the identifiers of the
#'   models.}
#'   \item{\code{Name}}{a factor containing the names of the predictor error
#'   results (not returned in case of only one column of prediction error
#'   results with the default name).}
#'   \item{\code{PE}}{the estimated prediction errors.}
#'   \item{\code{Lower}}{the lower end points of the error bars (only returned
#'   if \code{reps} is \code{FALSE}).}
#'   \item{\code{Upper}}{the upper end points of the error bars (only returned
#'   if \code{reps} is \code{FALSE}).}
#' }
#'
#' @note Duplicate indices in \code{subset} or \code{select} are removed such
#' that all models and prediction error results are unique.
#'
#' @author Andreas Alfons
#'
#' @keywords utilities
#'
#' @import ggplot2

NULL


#' @rdname perry-deprecated
#' @method fortify perry
#' @export

fortify.perry <- function(model, data, select = NULL,
                          reps = model$splits$R > 1, seFactor = NA, ...) {
    .Deprecated("setupPerryPlot")
    # initializations
    reps <- isTRUE(reps)
    # extract subset of models
    model <- subset(model, select=select)
    if(reps) {
        PE <- model$reps
        if (is.null(PE)) stop("replications not available")
        else PE <- as.data.frame(PE)
    } else PE <- as.data.frame(t(model$pe))
    if(npe(model) == 0) stop("empty prediction error object")
    # stack selected results on top of each other
    fitName <- defaultFitNames(1)
    peName <- defaultNames(1)
    peNames <- peNames(model)
    n <- nrow(PE)
    Fit <- data.frame(Fit=rep.int(fitName, n))
    # no column for conditional plots if there is only one method with default
    # name
    if(isTRUE(peNames == peName)) PE <- cbind(Fit, PE)
    else {
        PE <- lapply(peNames,
                     function(j) cbind(Fit, Name=rep.int(j, n), PE=PE[, j]))
        PE <- do.call(rbind, PE)
        names(PE) <- c("Fit", "Name", peName)
        attr(PE, "facets") <- ~ Name
    }
    # add data for error bars unless all replications are requested
    if(!reps) {
        if(is.null(seFactor)) seFactor <- NA
        halflength <- seFactor * model$se
        PE$Lower <- PE[, peName] - halflength
        PE$Upper <- PE[, peName] + halflength
    }
    # return data
    PE
}


#' @rdname perry-deprecated
#' @export

fortify.perrySelect <- function(model, data, subset = NULL, select = NULL,
                                reps = model$splits$R > 1, seFactor = model$seFactor, ...) {
    .Deprecated("setupPerryPlot")
    # initializations
    reps <- isTRUE(reps)
    # extract subset of models
    model <- subset(model, subset=subset, select=select)
    fits <- fits(model)
    if(reps) {
        PE <- model$reps
        if(is.null(PE)) stop("replications not available")
    } else PE <- model$pe
    if(nfits(model) == 0 || npe(model) == 0)
        stop("empty prediction error object")
    # ensure that models are shown in the correct order and drop unused levels
    # ensure that correct values are shown for a numeric tuning parameter
    if(!is.numeric(PE[, "Fit"])) {
        fits <- fits(model)
        PE$Fit <- factor(PE[, "Fit"], levels=fits)
    }
    # stack selected results on top of each other
    peName <- defaultNames(1)
    peNames <- peNames(model)
    n <- nrow(PE)
    # no column for conditional plots if there is only one column of results
    # with default name
    if(!isTRUE(peNames == peName)) {
        Fit <- PE[, "Fit", drop=FALSE]
        PE <- lapply(peNames,
                     function(j) cbind(Fit, Name=rep.int(j, n), PE=PE[, j]))
        PE <- do.call(rbind, PE)
        names(PE) <- c("Fit", "Name", peName)
        attr(PE, "facets") <- ~ Name
    }
    # add data for error bars unless all replications are requested
    if(!reps) {
        if(is.null(seFactor)) seFactor <- NA
        halflength <- seFactor * unlist(model$se[, peNames], use.names=FALSE)
        PE$Lower <- PE[, peName] - halflength
        PE$Upper <- PE[, peName] + halflength
    }
    # return data
    PE
}


#' @rdname perry-deprecated
#' @export

fortify.perryTuning <- function(model, data, ...) {
    .Deprecated("setupPerryPlot")
    # adjust column specifying the model in case of only one tuning parameter
    if(ncol(model$tuning) == 1) fits(model) <- model$tuning[, 1]
    # call method for class "perrySelect"
    PE <- fortify.perrySelect(model, ...)
    # return data
    PE
}


#' @rdname perry-deprecated
#' @method perryPlot default
#' @export

perryPlot.default <- function(object,
                              method = c("box", "density", "dot", "line"),
                              mapping, facets = attr(object, "facets"), ...) {
    # initializations
    if(is.null(object$Lower) && is.null(object$Upper)) {
        method <- match.arg(method)
    } else {
        choices <- eval(formals()[["method"]])
        if(identical(method, choices)) method <- "dot"
        else method <- match.arg(method, c("dot", "line"))
    }
    # call function for selected plot
    if(method == "box") {
        boxPlotFortified(object, mapping=mapping, facets=facets, ...)
    } else if(method == "density") {
        densityPlotFortified(object, mapping=mapping, facets=facets, ...)
    } else if(method == "line") {
        linePlotFortified(object, mapping=mapping, facets=facets, ...)
    } else dotPlotFortified(object, mapping=mapping, facets=facets, ...)
}

# ----------

boxPlotFortified <- function(data, mapping, facets = attr(data, "facets"),
                             main = NULL, xlab = NULL, ylab = NULL, ...) {
    # define aesthetic mapping for box plot
    if(missing(mapping)) mapping <- aes_string(x="Fit", y="PE", group="Fit")
    # define default axis label
    if(is.null(ylab)) ylab <- "Prediction error"
    # generate plot
    p <- ggplot(data, mapping) + geom_boxplot(...) +
        labs(title=main, x=xlab, y=ylab)
    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
}

# ----------

densityPlotFortified <- function(data, mapping, facets = attr(data, "facets"),
                                 main = NULL, xlab = NULL, ylab = NULL, ...) {
    # define aesthetic mapping for density plot
    if(missing(mapping)) {
        if(nlevels(data[, "Fit"]) > 1 || length(unique(data[, "Fit"])) > 1)
            mapping <- aes_string(x="PE", group="Fit", color="Fit")
        else mapping <- aes_string(x="PE")
    }
    # define default axis label
    if(is.null(xlab)) xlab <- "Prediction error"
    # generate plot
    p <- ggplot(data, mapping) + geom_density(...) +
        labs(title=main, x=xlab, y=ylab)
    if(is.numeric(data[, "Fit"]))
        p <- p + scale_color_continuous(breaks=unique(data[, "Fit"]))
    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
}

# ----------

dotPlotFortified <- function(data, mapping, facets = attr(data, "facets"),
                             main = NULL, xlab = NULL, ylab = NULL, ...) {
    # define aesthetic mapping for box plot
    if(missing(mapping))
        mapping <- aes_string(x="Fit", y="PE", ymin="Lower", ymax="Upper")
    # define default axis label
    if(is.null(ylab)) ylab <- "Prediction error"
    # generate plot
    p <- ggplot(data, mapping) + geom_pointrange(...) +
        labs(title=main, x=xlab, y=ylab)
    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
}

# ----------

linePlotFortified <- function(data, mapping, facets = attr(data, "facets"),
                              main = NULL, xlab = NULL, ylab = NULL, ...) {
    # define aesthetic mapping for box plot
    if(missing(mapping))
        mapping <- aes_string(x="Fit", y="PE", ymin="Lower", ymax="Upper")
    # define default axis label
    if(is.null(ylab)) ylab <- "Prediction error"
    # generate plot
    p <- ggplot(data, mapping) + geom_line(...) + geom_pointrange(...) +
        labs(title=main, x=xlab, y=ylab)
    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
}