R/ggconventions.r

In trevorld/ggconventions: A Framework for Adding Cultural Conventions to ggplot2 Graphs

#' ggconventions
#' 
#' Package to add conventions to ggplot2 graphs
#' @name ggconventions
#' @docType package
#' @import ggplot2
NULL

#' This is data of survivors of Titanic sinking.  Modified from \code{datasets::Titanic}.
#' 
"gender_data"

#' This is data of profits and losses in the FTSE.  Modified from \code{datasets::EuStockMarkets}.
#' 
"profit_data"


#' Utility function that allows automatic dispatching of convention scales
#'
#' Utility function that allows automatic dispatching of convention scales,
#' not to be directly used by user
#' @rdname ggconventions-utilities
#' @param y An object with an attribute \code{convention}
#' @export
scale_type.convention <- function(y) { 
    attr(y, "convention")
}

#' Membership function for convention class
#'
#' \code{is.convention} is the membership function for the convention class
#' @rdname ggconventions-utilities
#' @param x Object to be tested
#' @examples
#' source(system.file("conventions/gender.R", package="ggconventions"))
#' data("gender_data", package="ggconventions")
#' sapply(c_transform(gender_data), is.convention)
#' @export
is.convention <- function(x) {
    "convention" %in% class(x)
}

#' Add convention scales to ggplot object
#'
#' \code{add_c_scales} adds convention scales to ggplot object
#' currently needed if facets are specified
#' otherwise scales are automatically dispatched
#' @param gg A ggplot object, mappings must be simple matches to fields
#' @examples
#' require("ggplot2")
#' source(system.file("conventions/gender.R", package="ggconventions"))
#' data("gender_data", package="ggconventions")
#' gg <- qplot(x=class, y=survivors, colour=gender, shape=gender, geom="blank",
#'    data=c_transform(gender_data)) + geom_point(size=5)
#' gg
#' # The following are equivalent
#' add_c_scales(gg + facet_grid(. ~ gender))
#' gg + facet_grid(. ~ gender) + scale_colour_gender() + scale_shape_gender() 
#' # gg + facet_grid(. ~ gender) # gives an error
#' @export
add_c_scales <- function(gg) {
    for(aesthetic in names(gg$mapping)) {
        variable <- as.character(gg$mapping[[aesthetic]])
        if(is.convention(gg$data[, variable])) {
            scale_name <- sprintf("scale_%s_%s", aesthetic, 
                    scale_type.convention(gg$data[, variable]))
            gg <- gg + get(scale_name)()
        }
    }
    gg
}

#' Functions for listing and loading conventions contained in other packages
#'
#' \code{load_conventions} loads in convention(s) contained in other packages and
#' \code{list_conventions} lists convention(s) contained in other packages
#' @param convention Pattern passed to list.files, default is to list all files
#' @param package Package to look in
#' @param directory Directory within package to look in
#' @examples
#'  list_conventions(package="ggconventions")
#'  load_conventions("redblack", package="ggconventions") # just one convention
#'  load_conventions(package="ggconventions") # all of them
#' @rdname list_load_conventions
#' @export
load_conventions <- function(convention="*", package="ggconventions",
        directory="conventions") {
    for(file in list_conventions(convention, package, directory))
        source(file.path(system.file(directory, package=package), file))
    invisible(NULL)
}

#' @rdname list_load_conventions
#' @export
list_conventions <- function(convention="*", package="ggconventions",
        directory="conventions") {
    list.files(path=system.file(directory, package=package), pattern=convention)
}

#' ggconventions wrappers around ggplot
#'
#' \code{ct_ggplot} ("conventions transform ggplot"), \code{cf_ggplot} ("conventions fortify ggplot"),
#' provide wrappers which takes a data frame and applies \code{c_transform} and then the appropriate
#' plot function
#' @param data Data frame passed to \code{c_transform} and then transformed data frame to ggplot
#' @param ... Passed to ggplot
#' @param variables Passed to \code{c_transform}
#' @param fortify_data Passed to \code{c_transform}, set to TRUE for \code{cf_ggplot}
#' @param prefix Passed to \code{c_transform}
#' @rdname ct_ggplot
#' @examples
#' require("ggplot2")
#' source(system.file("conventions/gender.R", package="ggconventions"))
#' data("gender_data", package="ggconventions")
#' ct_ggplot(gender_data, 
#'     aes(x=class, y=survivors, colour=gender, shape=gender)) +
#'     geom_point(size=7) + ggtitle("# adult survivors of Titanic")
#' source(system.file("conventions/redblack.R", package="ggconventions"))
#' data("profit_data", package="ggconventions")
#' cf_ggplot(profit_data, aes(x=Index, y=profit, 
#'        colour=c.profit, fill=c.profit)) + geom_bar(stat='identity')
#' @export
ct_ggplot <- function(data, ..., variables=getOption("conventions", NULL), fortify_data=FALSE, prefix="c.") {
    data <- c_transform(data, variables=variables, fortify_data=fortify_data, prefix=prefix)
    ggplot(data, ...)
}

#' @rdname ct_ggplot
#' @export
cf_ggplot <- function(data, ..., variables=getOption("conventions", NULL), prefix="c.") {
    ct_ggplot(data, ..., variables=variables, fortify_data=TRUE, prefix=prefix)
}

#' Utilities for transforming data frames with convention aware series
#'
#' \code{c_transform} replaces or adds series to data frames with convention
#' aware series, \code{c_fortify} is a wrapper around \code{c_transform}
#' that defaults to adding new series rather than replacing series
#' @rdname c_transform
#' @param data Data frame
#' @param variables Which variables to transform, if NULL try all of them
#' @param fortify_data If TRUE add new variables with \code{prefix} instead of replacing them
#' @param prefix Prefix to use if \code{fortify_data} is TRUE.
#' @export
#' @examples
#' require("ggplot2")
#' source(system.file("conventions/gender.R", package="ggconventions"))
#' data("gender_data", package="ggconventions")
#' qplot(x=class, y=survivors, colour=gender, shape=gender, 
#'   data=c_transform(gender_data), geom="blank") + geom_point(size=5)
#' qplot(x=class, y=survivors, colour=gender, shape=c.gender, 
#'    data=c_fortify(gender_data), geom="blank") + geom_point(size=5)
c_transform <- function(data, variables=getOption("conventions", NULL), 
        fortify_data=FALSE, prefix="c.") {
    if(is.null(variables)) variables <- names(data)
    for(var in intersect(variables, names(data))) {
        as_convention <- tryCatch(get(sprintf("as_convention_%s", var)),
                                    error=function(e) { NULL })
        if(!is.null(as_convention)) {
            newvar <- ifelse(fortify_data, sprintf("%s%s", prefix, var), var)
            data[, newvar] <- as_convention(data[, var])
        }
    }
    data
}

#' @rdname c_transform
#' @export
c_fortify <- function(data, variables=getOption("conventions", NULL), prefix="c.") {
    c_transform(data, variables, fortify_data=TRUE, prefix=prefix)
}