# -------------------------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------------------ # # # # File Name : gg_Helper_Funcs.r # # Last Updated Funclist : 19 Feb 2015, 1:05 PM (Thursday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : extrafont, ggplot2, reshape2, stats # # Packages Used via NS : NA # # # # ------------------------------------------------------------------------------------------------------------------------------------ # # # # is.gg ( x ) # # facetbackground ( fill=NULL, colour=NULL, size=NULL, linetype=NULL, color=NULL ) # # legendtop ( notitle=FALSE ) # # legendbottom ( notitle=FALSE ) # # legendTitleOff ( ) # # nolegend ( ) # # nolegend ( ... ) # # noaxis ( ... ) # # noaxis.x ( ... ) # # noaxis.y ( ... ) # # nogridminor ( ... ) # # gg_xyline ( linetype=4, color="red", size=0.5, slope=1 ) # # nogridmajor ( ... ) # # billions.y ( limits=NULL, breaks=NULL ) # # millions.y ( limits=NULL, breaks=NULL ) # # millions.x ( limits=NULL, breaks=NULL ) # # thousands.y ( limits=NULL ) # # thousands.x ( limits=NULL ) # # comma.x ( limits=NULL ) # # comma.y ( limits=NULL ) # # comma_10.x ( limits=NULL ) # # comma_10.y ( limits=NULL ) # # percent.x ( limits=NULL ) # # percent.y ( limits=NULL ) # # gg_text ( text, cex=1 # # confirmAxisArgument ( axis ) # # , fontface=c("plain", "bold", "italic", "bold italic"), just=c("center", "left", "right", "bottom", "top") ) # # dollar ( limits=NULL, breaks=NULL, units="ones", axis=c("x", "y") ) # # years ( limits=NULL, breaks=NULL, axis=c("x", "y"), format="%Y" ) # # create_axis_functions ( funcs=c("dollar", "years"), envir=globalenv() ) # # dollar_scaled ( x, units="ones", nsmall=0, dict.dollar_scales=getDict("dict.dollar_scales"), symbol="$" ) # # gg_vline ( vline=NULL, vline_value=vline, vline_color=color, vline_alpha=alpha # # , vline_thickness=size, size=0.75, vec=DT[[x]], DT, x, color="#5786ff", alpha=0.75 ) # # gg_hline ( hline=NULL, hline_value=hline, hline_color=color, hline_alpha=alpha # # , hline_thickness=size, size=0.75, vec=DT[[y]], DT, y, color="#5786ff", alpha=0.75 ) # # gg_cleanColumnName ( colName, spaces=c("_", "-", ".", " ") ) # # gg_extract_legend ( P, position=c("bottom", "top", "left", "right") ) # # color_by_dict ( dict.with.names, title.for.legend=attr(dict.with.names, "title"), ..., values, colors ) # # fill_by_dict ( dict.with.names, title.for.legend=attr(dict.with.names, "title"), ..., values, colors ) # # alphaScale ( V, log=TRUE, zero.insert=all(V >= 0L, na.rm=TRUE), min.alpha=0.1, max.alpha=1 ) # # labels.percent ( yCol, textCol=yCol, size=2, digs=1 ) # # subtext ( main, subtext=NULL, line3="", body.main="plain", body.subtext="italic", body.line3="italic" ) # # subtitle ( title, subtitle, DEPRECATED="use subtext() instead" ) # # ggInsertLayer ( P, after=0, ... ) # # ggShowColors ( ) # # ggShowShapes ( mx=25, x.mx=5 ) # # ggShapeCheck ( shps=c(16, 19, 20) ) # # gg_add_legend ( P, legend, position=c("bottom", "top", "left", "right") ) # # ggShowFonts ( text="", fontsize=2 ) # # angledtext ( deg=20, x=deg, y=deg ) # # relativetext ( x=0.8, y=x ) # # fontface.axis ( font=c("Helvetica", "Arial", "Bookman"), face=c("plain", "bold", "italic", "bold.italic") ) # # relativefacettext ( x=0.8, y=x ) # # # # # # # # ------------------------------------------------------------------------------------------------------------------------------------ # # -------------------------------------------------------------------------------------------------------------------------------------- # ## TODO: ## facet :: http://stackoverflow.com/questions/11353287/how-do-you-add-a-general-label-to-facets-in-ggplot2 showLineTypes <- function() { # linetype reference: # http://sape.inf.usi.ch/quick-reference/ggplot2/linetype d=data.frame(lt=c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash", "1F", "F1", "4C88C488", "12345678")) ggplot() + scale_x_continuous(name="", limits=c(0,1), breaks=NULL) + scale_y_discrete(name="linetype") + scale_linetype_identity() + geom_segment(data=d, mapping=aes(x=0, xend=1, y=lt, yend=lt, linetype=lt)) } is.gg <- function(x) { inherits(x, "gg") } gg_xyline <- function(linetype="longdash", color="red", size=0.5, slope=1) { geom_abline(x=1, y=slope, linetype=linetype, size=size, color=color) } gg_text <- function(text, cex=1.00, fontface=c("plain", "bold", "italic", "bold italic"), just=c("center", "left", "right", "bottom", "top")) { ## Quick modifier for text fontface <- match.arg(fontface) just <- match.arg(just) textGrob(label=text, gp=gpar(cex=cex, fontface=fontface)) } gg_extract_legend <- function(P, position=c("bottom", "top", "left", "right")) { ## adapted from: https://github.com/hadley/ggplot2/wiki/Share-a-legend-between-two-ggplot2-graphs position <- match.arg(position) tmp <- ggplot_gtable(ggplot_build(P + theme(legend.position=position))) leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box") if (!length(leg)) { warning ("There is no legend in the given grob") return(NULL) } legend <- tmp$grobs[[leg]] return(legend) } gg_add_legend <- function(P, legend, position=c("bottom", "top", "left", "right")) { ## adapted from: https://github.com/hadley/ggplot2/wiki/Share-a-legend-between-two-ggplot2-graphs position <- match.arg(position) lheight <- sum(legend$height) PLOTS <- list(P, legend) PLACEMENTS <- list(1, unit.c(unit(1, "npc") - lheight, lheight)) if (position %in% c("top", "left")) { PLOTS <- rev(PLOTS) PLACEMENTS[[2]] <- rev(PLACEMENTS[[2]]) } ## determine if using cols or rows setattr(PLACEMENTS, "names", if(position %in% c("top", "bottom")) c("ncol", "heights") else c("nrow", "width")) do.call(grid.arrange, c(PLOTS, PLACEMENTS)) # grid.arrange( # P, # legend, # ncol = 1, # heights = unit.c(unit(1, "npc") - lheight, lheight)) } ## This is a collection of the names of scale-functions. ## Useful for input check in plotting functions gg_scale_functions <- c( "billions" , "millions" , "thousands" , "comma" , "comma_10" , "percent" , "dollar" , "years" , "log" ) angledtext <- function(deg=0, x=deg, y=deg, what=c("text", "title")) { ## Sets the text on an angle what <- match.arg(what) if (what == "text") theme(axis.text.x=element_text(angle=x), axis.text.y=element_text(angle=y)) else if (what == "title") theme(axis.text.x=element_text(angle=x), axis.text.y=element_text(angle=y)) } relativetext <- function(rel=1, x=rel, y=rel, what=c("text", "title", "facet", "facet_x", "facet_y", "facetx", "facety")) { ## Sets the text on an angle what <- match.arg(what) if (what == "text") theme(axis.text.x=element_text(size=rel(x)), axis.text.y=element_text(size=rel(y))) else if (what == "title") theme(axis.title.x=element_text(size=rel(x)), axis.title.y=element_text(size=rel(y))) else if (what == "facet") theme(strip.text.x=element_text(size=rel(x)), strip.text.y=element_text(size=rel(y))) else if (what %in% c("facet_x", "facetx")) theme(strip.text.x=element_text(size=rel(x))) else if (what %in% c("facet_y", "facety")) theme(strip.text.y=element_text(size=rel(y))) } fontface.axis <- function(font=c("Helvetica", "Arial", "Bookman"), face=c("plain","bold","italic","bold.italic")) { font <- match.arg(font) face <- match.arg(face) theme(axis.text=element_text(family=font, face=face)) } relativefacettext <- function(x=.8, y=x) { warning("use relativetext(what='facet_x'); 'facet', 'facet_x', or 'facet_y'") ## Sets the text on an angle theme(strip.text.x=element_text(size=rel(x)), strip.text.y=element_text(size=rel(y))) } facetbackground <- function(fill=NULL, colour=NULL, size=NULL, linetype=NULL, color=NULL) { theme(strip.background = element_rect(fill=fill, colour=colour, size=size, linetype=linetype, color=color)) } ## Control facet_labels # strip.background background of facet labels (element_rect; inherits from rect) # strip.text facet labels (element_text; inherits from text) # strip.text.x facet labels along horizontal direction (element_text; inherits from strip.text) # strip.text.y facet labels along vertical direction (element_text; inherits from strip.text) # ------------------------------------------ # legendtop <- function(notitle=FALSE) { if (isTRUE(notitle)) theme(legend.position="top") + theme(legend.title=element_blank()) else theme(legend.position="top") } legendbottom <- function(notitle=FALSE) { if (isTRUE(notitle)) theme(legend.position="bottom") + theme(legend.title=element_blank()) else theme(legend.position="bottom") } legendTitleOff <- function() { theme(legend.title = element_blank()) } nolegend <- function() { theme(legend.position="none") } .nolegend <- function(...) { warning("\nThe object '.nolegend' has been changed to 'nolegend()'\n(Remove the dot; Add parens)" ) nolegend(...) } noaxis <- function(...) { noaxis.x(...) + noaxis.y(...) } noaxis.x <- function(...) { theme(axis.ticks.x=element_blank(), axis.text.x=element_blank()) } noaxis.y <- function(...) { theme(axis.ticks.y=element_blank(), axis.text.y=element_blank()) } nogridminor <- function(...) { theme(panel.grid.minor=element_blank()) } nogridmajor <- function(...) { theme(panel.grid.major=element_blank()) } # ------------------------------------------ # ### THE PROBLEM WITH breaks=NULL ### is that this removes the labels. NULL != "ignore" ### billions.y <- function(limits=NULL, breaks=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma if (is.null(limits)) scale_y_continuous(labels=function(yy) .scaling_func(yy/1e9)) else if (is.null(breaks)) scale_y_continuous(labels=function(yy) .scaling_func(yy/1e9), limits=limits) else scale_y_continuous(labels=function(yy) .scaling_func(yy/1e9), limits=limits, breaks=breaks) } billions.x <- function(limits=NULL, breaks=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma if (is.null(limits)) scale_y_continuous(labels=function(yy) .scaling_func(yy/1e9)) else if (is.null(breaks)) scale_y_continuous(labels=function(yy) .scaling_func(yy/1e9), limits=limits) else scale_y_continuous(labels=function(yy) .scaling_func(yy/1e9), limits=limits, breaks=breaks) } millions.y <- function(limits=NULL, breaks=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma if (is.null(limits)) scale_y_continuous(labels=function(yy) .scaling_func(yy/1e6)) else if (is.null(breaks)) scale_y_continuous(labels=function(yy) .scaling_func(yy/1e6), limits=limits) else scale_y_continuous(labels=function(yy) .scaling_func(yy/1e6), limits=limits, breaks=breaks) } millions.x <- function(limits=NULL, breaks=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma if (is.null(limits)) scale_x_continuous(labels=function(yy) .scaling_func(yy/1e6)) else if (is.null(breaks)) scale_x_continuous(labels=function(yy) .scaling_func(yy/1e6), limits=limits) else scale_x_continuous(labels=function(yy) .scaling_func(yy/1e6), limits=limits, breaks=breaks) } thousands.y <- function(limits=NULL, breaks=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma if (is.null(limits)) scale_y_continuous(labels=function(yy) .scaling_func(yy/1e3)) else if (is.null(breaks)) scale_y_continuous(labels=function(yy) .scaling_func(yy/1e3), limits=limits) else scale_y_continuous(labels=function(yy) .scaling_func(yy/1e3), limits=limits, breaks=breaks) } thousands.x <- function(limits=NULL, breaks=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma if (is.null(limits)) scale_x_continuous(labels=function(yy) .scaling_func(yy/1e3)) else if (is.null(breaks)) scale_x_continuous(labels=function(yy) .scaling_func(yy/1e3), limits=limits) else scale_x_continuous(labels=function(yy) .scaling_func(yy/1e3), limits=limits, breaks=breaks) } # old # thousands.y <- function(limits=NULL, dollars=FALSE) { # old # .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma # old # scale_y_continuous(labels=function(yy) .scaling_func(yy/1e3), limits=limits) # old # } # old # # old # thousands.x <- function(limits=NULL, dollars=FALSE) { # old # .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma # old # scale_x_continuous(labels=function(yy) .scaling_func(yy/1e3), limits=limits) # old # } # ------------------------- # log.x <- function(limits=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma scale_x_log10(labels=.scaling_func, limits=limits) } log.y <- function(limits=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma scale_y_log10(labels=.scaling_func, limits=limits) } comma.x <- function(limits=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma scale_x_continuous(labels=.scaling_func, limits=limits) } comma.y <- function(limits=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma scale_y_continuous(labels=.scaling_func, limits=limits) } comma_10.x <- function(limits=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma scale_x_log10(labels=.scaling_func, limits=limits) } comma_10.y <- function(limits=NULL, dollars=FALSE) { .scaling_func <- if (isTRUE(dollars)) scales::dollar else scales::comma scale_y_log10(labels=.scaling_func, limits=limits) } percent.x <- function(limits=NULL, dollars=FALSE) { if (isTRUE(dollars)) warning("A value of TRUE was passed to the 'dollars' argument of percent.x(); the dollars argument is just a dummy to allow for generalization of the scaling functions. What was the intention when setting the value to TRUE?") scale_x_continuous(labels=percent, limits=limits) } percent.y <- function(limits=NULL, dollars=FALSE) { if (isTRUE(dollars)) warning("A value of TRUE was passed to the 'dollars' argument of percent.y(); the dollars argument is just a dummy to allow for generalization of the scaling functions. What was the intention when setting the value to TRUE?") scale_y_continuous(labels=percent, limits=limits) } confirmAxisArgument <- function(axis) { ## wrapper for the commonly used clause to check if any of axis are not x and/or y msg <- "'axis' argument must be either 'x' or 'y' but not both" if (!length(axis)) stop("The 'axis' argument has 0 length.\n", msg) if (length(axis) > 1) stop("The 'axis' argument has length greater than 1\n", msg) if (tolower(axis) %ni% c("x", "y")) stop (msg) } dollar <- function(limits=NULL, breaks=NULL, units="ones", axis=c("x", "y"), dollar=TRUE) { ## confirm axis is valid input confirmAxisArgument(axis) ## units is the same arg used in dollar_scaled. force it for scoping purposes force(units) # old: label.function <- function(x, units2=units) # old: dollar_scaled(x, units=units2) # old: # old: args <- as.list(c(labels=label.function, limits=limits, breaks=breaks)) args <- as.list(c(labels=function(x) dollar_scaled(x, units=units), breaks=breaks)) if (!is.null(limits)) { if (length(limits) != 2) warning("limits sent to one of the dolalr functions does not have length 2") args <- c(args, limits=list(limits)) } gFun <- sprintf("scale_%s_continuous", axis) do.call(match.fun(gFun), args) } years <- function(limits=NULL, breaks=NULL, axis=c("x", "y"), format="%Y") { ## confirm axis is valid input confirmAxisArgument(axis) args <- as.list(c(labels=function(x) dollar_scaled(x, units=units), limits=limits, breaks=breaks)) gFun.nm <- sprintf("scale_%s_date", axis) gFun <- match.fun(gFun.nm) if (!is.null(limits) && !is.null(breaks)) gFun(labels = date_format(format), limits=limits, breaks=breaks) else if (!is.null(breaks)) gFun(labels = date_format(format), breaks=breaks) else if (!is.null(limits)) gFun(labels = date_format(format), limits=limits) else gFun(labels = date_format(format)) } ## CREATE THEM ALL OF THE .x and .y VERSIONS AUTOMATICALLY .create_axis_functions <- function(funcs=c("dollar", "years"), envir=globalenv()) { require(stats) ## for setNames thisfuncs.name <- as.character(as.list(match.call())[[1]]) for (func in funcs) { ## Confirm that the main function (non-axis version) exists if (!exists(func) || !is.function(get(func))) stop(func, "() does not exist or is not a function") ## grab the formal arguments ag <- formals(func) ## create a copy with the "axis" argument dropped ag.noaxis <- ag[names(ag) != "axis"] ## Iterate over each possible value of the "axis" argument for (var in eval(ag[["axis"]])) { ag.assign <- c(setNames(nm=names(ag.noaxis)), setNames(obj=pasteQ(var, w="", q='"'), nm="axis")) template <- pasteC(sprintf("%s=%s", names(ag.noaxis), ifelse(sapply(ag.noaxis, is.character), sapply(ag.noaxis, sprintf, fmt="\"%s\""), ag.noaxis)), C=", ") bodycall <- pasteC(sprintf("%s=%s", names(ag.assign), ag.assign), C=", ") comment <- sprintf("## This function was generated programatically from %s()\n## using %s()", func, thisfuncs.name) name <- sprintf("%s.%s", func, var) value <- sprintf("function(%s) {\n%s\n\n %s(%s)\n}\n", template, comment, func, bodycall) assign(x=name, value=eval(parse(text=value)), envir=envir) } ## // end for (var ... ) } ## // end for (func ... ) return(invisible()) } ## EXECUTE THIS ONE FUNCTION .create_axis_functions() dollar_scaled <- function(x, units="ones", nsmall=0, dict.dollar_scales=getDict("dict.dollar_scales"), symbol="$") { ## used for ggplot scale_x_continuous(labels=dollar_scaled) ## nsmall: How many digits to round out to. set to NA to auto find ## force(dict.dollar_scales) units <- match.arg(arg=units, choices=names(dict.dollar_scales)) x.scaled <- x / dict.dollar_scales[[units]] ## distance between ranges dist <- diff(range(x.scaled, na.rm=TRUE)) ## Keeping in mind that this function is used for axis-labels, we normally want to HIDE the decimal ## unless the decimal is what distinguishes one line from another, such as .002, .003 ## But NOT 5.002, 6.003 Here the decimal is of no use ## Thus, if all the x.scaled are small OR the distance between them is very small, use the calculated nsmall ## where the calculated nsmall is one less than the log of the distance (rounded down) if (missing(nsmall) || is.na(nsmall)) nsmall <- ifelse (all(x.scaled < 1, na.rm=TRUE) || dist < 1, yes = { -(floor(log10(dist)) - 1) }, no = 0) if (nsmall < 0) nsmall <- 0 if (nsmall > 20) nsmall <- 20 ret <- paste0(symbol, format(x.scaled, nsmall = nsmall, trim = TRUE, big.mark = ",", scientific = FALSE, digits = 1L)) ret[is.na(x.scaled)] <- NA return(ret) } gg_vline <- function( vline = NULL # synonym to avoid multiple matches , vline_value = vline , vline_color = color , vline_alpha = alpha , vline_thickness = size , linetype=type , size = .75 , vec.from_parent_plot_for_type_comparison=DT.from_parent_plot_for_type_comparison[[x]] , DT.from_parent_plot_for_type_comparison , x.from_parent_plot_for_type_comparison , color = "#5786ff" , alpha = 0.75 , type = "longdash" ) { ### vec: The corresponding x-values on the parent plot. It's pupose is simply to compare class against vline_value ## and then coerce as necessary ## If DT$x is a date/time, convert the value to numeric if (!missing(vec.from_parent_plot_for_type_comparison) || (!missing(DT.from_parent_plot_for_type_comparison) && !missing(x.from_parent_plot_for_type_comparison))) { ## For shorthand x <- x.from_parent_plot_for_type_comparison vec <- vec.from_parent_plot_for_type_comparison if (is.date_or_time(vec)) { if (is.Date(vec) && !is.Date(vline_value)) vline_value <- as.Date(vline_value, origin=.origin) if (is.POSIXct(vec) && !is.POSIXct(vline_value)) vline_value <- as.POIXct(vline_value, origin=.origin.utc) if (is.POSIXlt(vec) && !is.POSIXlt(vline_value)) vline_value <- as.POIXlt(vline_value, origin=.origin.utc) vline_value <- as.numeric(vline_value) } } geom_vline(xintercept=vline_value, alpha=vline_alpha, color=vline_color, linetype=linetype, size=vline_thickness) } gg_hline <- function( hline = NULL # synonym to avoid multiple matches , hline_value = hline , hline_color = color , hline_alpha = alpha , hline_thickness = size , linetype=type , size = .75 , vec.from_parent_plot_for_type_comparison=DT.from_parent_plot_for_type_comparison[[y]] , DT.from_parent_plot_for_type_comparison , y.from_parent_plot_for_type_comparison , color = "#5786ff" , alpha = 0.75 , type = "longdash" ) { ### vec: The corresponding y-values on the parent plot. It's pupose is simply to compare class against vline_value ## and then coerce as necessary ## If DT$y is a date/time, convert the value to numeric if (!missing(vec.from_parent_plot_for_type_comparison) || (!missing(DT.from_parent_plot_for_type_comparison) && !missing(y.from_parent_plot_for_type_comparison))) { ## For shorthand y <- y.from_parent_plot_for_type_comparison vec <- vec.from_parent_plot_for_type_comparison if (is.date_or_time(vec)) { if (is.Date(vec) && !is.Date(hline_value)) hline_value <- as.Date(hline_value, origin=.origin) if (is.POSIXct(vec) && !is.POSIXct(hline_value)) hline_value <- as.POIXct(hline_value, origin=.origin.utc) if (is.POSIXlt(vec) && !is.POSIXlt(hline_value)) hline_value <- as.POIXlt(hline_value, origin=.origin.utc) hline_value <- as.numeric(hline_value) } } geom_hline(yintercept=hline_value, alpha=hline_alpha, color=hline_color, linetype=linetype, size=hline_thickness) } # ------------------------------------------ # gg_cleanColumnName <- function(colName, spaces=c("_", "-", ".", " ")) { colName[colName == "label_sc_group"] <- "Supply Chain" # topropper_keywords(gsub(regOr(spaces, escape=TRUE), " ", colName)) topropper_keywords(pasteC(camelSplit(colName, alsoSplit=spaces), C=" ")) %>% gsub(pat="Perc of", repl="Percent of", x=.) } color_by_dict <- function(dict.with.names, title.for.legend=attr(dict.with.names, "title"), ..., values, colors, use_fill_instead=FALSE) { ## values, colors :: optional args to be used in place of dict. dict will be created c(vlaues = colors) if (missing(dict.with.names) && (!missing(values) && !missing(colors))) dict.with.names <- setNames(obj=colors, nm=values) else if (identical(dict.with.names, "label_sc_group")) dict.with.names <- getDict("dict.colors.sc") else if (is.char_of_length1(dict.with.names, showWarnings=FALSE)) { if (exists(dict.with.names)) dict.with.names <- get(dict.with.names) else dict.with.names <- getDict(dict.with.names) } else if (!is.character(dict.with.names)) stop("Do not know how to use the dictionary given to color_by_dict()", call.=FALSE) if (isTRUE(use_fill_instead)) scale_fill_manual(values=dict.with.names, name=title.for.legend, ...) else scale_color_manual(values=dict.with.names, name=title.for.legend, ...) } fill_by_dict <- function(dict.with.names, title.for.legend=attr(dict.with.names, "title"), ..., values, colors) { # if (missing(dict.with.names) && (!missing(values) && !missing(colors))) # dict.with.names <- setNames(obj=colors, nm=values) # else if (identical(dict.with.names, "label_sc_group")) # dict.with.names <- getDict("dict.colors.sc") # else if (is.character(dict.with.names) && !exists(dict.with.names)) # dict.with.names <- getDict(dict.with.names) # scale_fill_manual(values=dict.with.names, name=title.for.legend, ...) ARGS <- collectArgs(except=c(if(missing(values)) "values", if (missing(colors)) "colors")) ARGS %<>% c(use_fill_instead = TRUE) do.call(color_by_dict, ARGS) } # ------------------------------------------ # alphaScale <- function(V, log=TRUE, zero.insert=all(V>=0L, na.rm=TRUE), min.alpha=.1, max.alpha=1) { # browser(expr=any(V<=1L), text="in alphaScale() in gg_Helper_Funcs.r") if (log) { V[V <= 0L] <- NA lV <- log(V) } ## add a zero, so that if we have a collection of large values, they do not get unnecessarilly srtetched if (zero.insert) lV <- c(lV, 0) ## Scale to [.1, 1], and drop the zero added scaled <- scaleunif(lV, min.alpha, max.alpha) ## NA's to Zero scaled <- removeNA(scaled, 0L) ## Drop the inserted zero before returning head(scaled, length(scaled)-zero.insert) } # ------------------------------------------ # ## Adding text labels to a graph, in the form of percentage labels.percent <- function(yCol, textCol=yCol, size=2, digs=1) { ll <- sprintf("fwp(%s, %s)", textCol, digs) yy <- sprintf("%s + (1/2 * mean(%s))", yCol, yCol) geom_text(aes_string(label=ll, y=yy), size=size) } ## Note: line3 used to be line3="" -- if something breaks, put it back subtext <- function(main, subtext=NULL, line3=NULL, line4=NULL, body.main="plain", body.subtext="italic", body.line3="italic", body.line4="italic") { if (is.null(line3) && !is.null(line4)) warning ("line4 is ignored when line3 is NULL") if (is.null(line4) || is.na(line4)) line4 <- NULL fontfaces <- c("plain", "italic", "bold", "bolditalic") ## body type body.main <- match.arg(body.main , fontfaces) body.subtext <- match.arg(body.subtext, fontfaces) body.line3 <- match.arg(body.line3, fontfaces) body.line4 <- match.arg(body.line4, fontfaces) ## allow for phrases like "horizontal bold(first bold word) represents the bold(worldwide) median average" ## Where the bold(x) portion will be appropriately spliced out main <- .splice_in_paste_and_bquote(main, bold_to_bolditalic=body.main=="italic", italic_to_bolditalic=body.main=="bold") subtext <- .splice_in_paste_and_bquote(subtext, bold_to_bolditalic=body.subtext=="italic", italic_to_bolditalic=body.subtext=="bold") line3 <- .splice_in_paste_and_bquote(line3, bold_to_bolditalic=body.line3=="italic", italic_to_bolditalic=body.line3=="bold") line4 <- .splice_in_paste_and_bquote(line4, bold_to_bolditalic=body.line3=="italic", italic_to_bolditalic=body.line3=="bold") ## Determine if subtext is being used or not nosubtext <- is.null(subtext) && (line3 == "" || is.null(line3)) ## Create the expression if (nosubtext && body.main == "plain") return(main) bmain <- if (body.main == "plain") ".(main)" else sprintf("%s(.(main))", body.main) bsub <- if (body.subtext == "plain") ".(subtext)" else sprintf("%s(.(subtext))", body.subtext) bline3 <- if (body.line3 == "plain") ".(line3)" else sprintf("%s(.(line3))", body.line3) bline4 <- if (body.line4 == "plain") ".(line4)" else sprintf("%s(.(line4))", body.line4) if (nosubtext) ret_text <- sprintf("bquote(%s)", bmain) else if (is.null(line3)) ret_text <- sprintf("bquote(atop(%s, %s))", bmain, bsub) else if (is.null(line4)) ret_text <- sprintf("bquote(atop(%s, atop(%s, %s)))", bmain, bsub, bline3) else ret_text <- sprintf("bquote(atop(%s, atop(%s, atop(%s, %s))))", bmain, bsub, bline3, bline4) ret <- eval(parse(text=ret_text)) return(ret) } .splice_in_paste_and_bquote <- function(x, bold_to_bolditalic=FALSE, italic_to_bolditalic=FALSE, funcs=c("bold", "italic", "frac", "over", "atop")) { ## TODO commas for atop, over, frac, etc if (is.null(x) || !nchar(x)) return(x) x <- gsub("\\*(.*?)\\*", "bold(\\1)", x) x <- gsub("\\_(.*?)\\_", "italic(\\1)", x) ## if none of the functions are found, return x unchanged if (is.null(x) || !(funcs %>% regOr %>% grepl(x))) return(x) ## split x around the keywords splat <- funcs %>% paste0("\\(") %>% regOr() %>% sprintf("(.*?)%s(.*)(\\))(.*?)", .) %>% gsub(repl="\\1\"_@_, \\2_@_\"\\3\"_@_\\4, _@_\"\\5", x) %>% strsplit("_@_") %>% {.[[1]]} if (bold_to_bolditalic) splat[splat == "bold("] <- "bolditalic(" if (italic_to_bolditalic) splat[splat == "italic("] <- "bolditalic(" ret_text <- splat %>% pasteC %>% sprintf("bquote(paste(\"%s\"))", .) ret <- eval(parse(text=ret_text)) return(ret) } subtitle <- function(title, subtitle, DEPRECATED = "use subtext() instead") { warning ("subtitle has been DEPRECATED -- use subtext() instead") subtext(main=title, subtext=subtitle, body.main="plain", body.subtext="italic") } # ------------------------------------------ # ggInsertLayer <- function(P, ..., after=0) { # P : Plot object # ... : additional layers, separated by commas (,) instead of plus sign (+) # after : Position where to insert new layers, relative to existing layers if (missing(...)) { warning ("No additional layers passed to ggInsertLayer() to insert into P. Returning P unchanged", call.=FALSE) return(P) } if (is.numeric(..1)) stop ("The first argument to ggInsertLayer other than 'P' is numeric. It should be a grob. \n\nHINT: Did you forget to name the 'after' parameter? ") if (after < 0) after <- after + length(P$layers) if (!length(P$layers)) P$layers <- list(...) else P$layers <- append(P$layers, list(...), after) return(P) } # ------------------------------------------ # ggShowColors <- function() { display.brewer.all() } show_color_scale <- function(colors) { ## Takes a color scale and creates a rectangular plot out of it image(matrix(1:400, 20), col = colors) } ggShowShapes <- function(mx=25, x.mx=5) { ddd <- data.table(val=seq(mx), mx=mx, x.mx=x.mx) ddd <- data.table(val=seq(mx)) ddd[, x := seq(x.mx)] ddd[, y := rev(rep(seq(mx/x.mx), each=x.mx))] ddd[, y.up := y+.15 + mx/1000] ggplot(data=ddd, aes(x=x)) + geom_point(aes(shape=factor(val), y=y.up), size=4.2) + geom_text(aes(label=val, y=(y-.1)), size=2) + scale_shape_manual(values=ddd$val) + theme(axis.ticks=element_blank(), axis.text=element_blank(), legend.position="none") + labs(x="", y="") } ggShapeCheck <- function(shps=c(16,19,20)) { L <- length(shps) ddd <- eval(parse(text=sprintf("CJ(%s)", paste(rep("shps", L), collapse=",")))) ddd[, x := seq(L)] ddd[, y := rev(rep(seq(.N/L), each=L))] ## ddd1 <- unique(ddd[, apply(.SD, 1, function(x) c(unique(x))), keyby=list(x, y)], by=NULL) ddd2 <- unique(ddd[, apply(.SD, 1, function(x) paste(unique(x) , collapse=", ")), keyby=list(x, y)], by=NULL) setnames(ddd1, "V1", "val") setnames(ddd2, "V1", "label") ddd <- unique(merge(ddd1, ddd2), by=c("val", "label")) ddd[, val.factor := factor(val, levels=shps)] ggplot(data=ddd, aes(x=x)) + geom_point(aes(y=y+.15, shape=val.factor, color=val.factor), size=6) + geom_text (aes(y=y-.15, label=label), size=3) + scale_shape_manual(values=ddd$val) + theme(axis.ticks=element_blank(), axis.text=element_blank()) + labs(x="", y="") } ggShowFonts <- function(text="", fontsize=2) { ## Adapted from http://www.cookbook-r.com/Graphs/Fonts/ require(reshape2) require(ggplot2) require(extrafont) fonttable <- read.table(header=TRUE, sep=",", stringsAsFactors=FALSE, text=' Short,Canonical mono,Courier sans,Helvetica serif,Times ,AvantGarde ,Bookman ,Helvetica-Narrow ,NewCenturySchoolbook ,Palatino ,URWGothic ,URWBookman ,NimbusMon URWHelvetica,NimbusSan ,NimbusSanCond ,CenturySch ,URWPalladio URWTimes,NimbusRom ') fonttable$pos <- 1:nrow(fonttable) fonttable <- melt(fonttable, id.vars="pos", measure.vars=c("Short","Canonical"), variable.name="NameType", value.name="Font") # Make a table of faces. Make sure factors are ordered correctly facetable <- data.frame(Face = factor(c("plain","bold","italic","bold.italic"), levels = c("plain","bold","italic","bold.italic"))) fullfonts <- merge(fonttable, facetable) fullfonts$label <- sprintf("%s%s", text, fullfonts$Font) pf <- ggplot(fullfonts, aes(x=NameType, y=pos)) + geom_text(aes(label=label, family=Font, fontface=Face), size=fontsize) + facet_wrap(~ Face, ncol=2) pf }