# ------------------------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------------------- # # # # File Name : gg_GenericProcessing.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 : NA # # Packages Used via NS : NA # # # # ----------------------------------------------------------------------------------------------------------------------- # # # # gg_confirm_aes_values ( DT, args.aes=c("x", "y", "color", "fill", "linetype"), envir=parent.frame() ) # # gg_GenericProcessing ( P, DT, x, y, size, line_alpha=1, thickness=size, color=NULL, fill=NULL # # , dict.colors=NULL, dict.fills=dict.colors, label=NULL, labelcolor=NULL # # , labelsize=2 * size # # , labelface=c("plain", "bold", "italic", "bolditalic"), label_y_up=0.05 # # , label_x_up=0, labeljitter=0, labeljitter_x=labeljitter, labeljitter_y=labeljitter # # , labelalpha=1, xscale=gg_findScaleAutomatically(DT=DT, nm=x) # # , yscale=gg_findScaleAutomatically(DT=DT, nm=y), xlims=NULL, ylims=NULL, xlab=NULL # # , ylab=NULL, xlab_append=NULL, ylab_append=NULL, xlab_line3=NULL, ylab_line3=NULL # # , title=NULL, title_append=NULL, title_size_rel=1, angledtext.degrees=0 # # , x_angledtext=angledtext.degrees, y_angledtext=angledtext.degrees # # , relativetext.size=1 # # , x_relativetext=relativetext.size - (0.25 * facet_has_free_xy$x) # # , y_relativetext=relativetext.size - (0.25 * facet_has_free_xy$y) # # , facet_formula=NULL # # , facet_scales=c("fixed", "free_x", "free_y", "free"), vline=NULL # # , vline_value=vline, vline_color="#5786ff", vline_alpha=line_alpha * 0.75 # # , vline_thickness=thickness * vline_scale, vline_scale=0.75, hline=NULL # # , hline_value=hline, hline_color="#5786ff", hline_alpha=line_alpha * 0.75 # # , hline_thickness=thickness * hline_scale, hline_scale=0.75 # # , legend=c("right", "bottom", "top", "left", "off"), legend_title_off=FALSE # # , legend_font_size_rel=0.7, legend_key_size_rel=legend_font_size_rel, ... ) # # gg_findScaleAutomatically ( vec, nm.vec=substitute(vec), DT=NULL, percent.allowed=TRUE ) # # # # # # # # ----------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------- # ## CALLED WITH ## do.call(gg_GenericProcessing, collectArgs(), quote=TRUE) showgg <- function() { ## Shows the arguments to the common gg wrappers ## For now, just gg_GenericProcessing h1 <- function(x) {if (!is.character(x)) x <- as.character(substitute(x)); sprintf("\n ---------- %20s ---------- ", x)} cat(h1(gg_GenericProcessing), fill=TRUE) print.function(gg_GenericProcessing) cat(h1(gg_confirm_aes_values), fill=TRUE) print.function(gg_confirm_aes_values) cat("\n") } ## These parameters are common to all graphs ## ## ----------------------------------------- ## gg_confirm_aes_values <- function(DT, args.aes=c("x", "y", "color", "fill", "linetype"), envir=parent.frame()) { for (arg in args.aes) { arg.got <- try(get(arg, envir=envir), silent=TRUE) # browser(expr=bb) if (isErr(arg.got) || (!is.null(arg.got) && !is.character(arg.got))) stop ("\nAll aes arguments (", pasteQand(args.aes), ") should be quoted characters or NULL. EG use\n x='date' not x=date\n\nHINT: Offending argument is '", arg, "'", call.=FALSE) if (!is.null(arg.got) && arg.got %ni% names(DT)) stop ("The ", arg, " aesthetic ('", arg.got, "') is not a column in the DT") } ## --------------------------------------------- ## } gg_GenericProcessing <- function(P ,DT, x, y, size , line_alpha = 1 , thickness=size ## Basic Aesthetics , color = NULL , fill = NULL , shape = NULL , dict = NULL , dict.colors = if (!is.null(color)) dict , dict.fills = if (!is.null(fill)) dict.colors , dict.shapes = if (!is.null(shape)) dict.colors ## label parameters , label = NULL , labelcolor = NULL ## can have length > 1, which will cause a "shadow" effect , labelsize = 2 * size , labelface = c("plain", "bold", "italic", "bolditalic") , label_y_up = 0.05 , label_x_up = 0 , labeljitter = 0 , labeljitter_x = labeljitter , labeljitter_y = labeljitter # diff(range(DT[[y]])) / 25 , labelalpha = 1 ## scale and limits , xscale=gg_findScaleAutomatically(DT=DT, nm=x, dollar=x_is_dollars) , yscale=gg_findScaleAutomatically(DT=DT, nm=y, dollar=y_is_dollars) , xlims=NULL , ylims=NULL , x_is_dollars=FALSE , y_is_dollars=FALSE ## labs and titles , xlab = NULL , ylab = NULL , xlab_append = NULL , ylab_append = NULL , xlab_line3 = NULL , ylab_line3 = NULL , title=NULL , title_append = NULL , title_size_rel = 1.0 ## angledtext & relativetext affect the x/y axis text , angledtext.degrees = 0 , x_angledtext = angledtext.degrees , y_angledtext = angledtext.degrees , relativetext.size = 1 , x_relativetext = relativetext.size - (0.25 * facet_has_free_xy$x) , y_relativetext = relativetext.size - (0.25 * facet_has_free_xy$y) , x_relativetitle = 1 , y_relativetitle = 1 , x_facet_relative_text = 1 , y_facet_relative_text = 1 ## facets , facet_formula = if (!missing(facet_x) || !missing(facet_y)) makeFormula(facet_y, facet_x) , facet_x = "." , facet_y = "." , facet_scales = c("fixed", "free_x", "free_y", "free") ## vline and hline , vline = NULL # synonym to avoid multiple matches , vline_value = vline , vline_color = "#5786ff" , vline_alpha = line_alpha * .75 , vline_thickness = thickness * vline_scale , vline_scale = .75 , hline = NULL # synonym to avoid multiple matches , hline_value = hline , hline_color = "#5786ff" , hline_alpha = line_alpha * .75 , hline_thickness = thickness * hline_scale , hline_scale = .75 ## legend params , legend = c("right", "bottom", "top", "left", "off") , legend_title_off = "DEPRECATED" , legend_title_on = TRUE , legend_font_size_rel = 0.7 , legend_key_size_rel = legend_font_size_rel , legend.color_on = TRUE , legend.fill_on = TRUE , legend.shape_on = TRUE , legend.linetype_on = TRUE , legend.size_on = TRUE , legend.alpha_on = TRUE ## margin parameters , margins = c(margin_top, margin_right, margin_bottom, margin_left) * margin_scale , margin_scale = NULL , margin_units = "mm" , margin_top = 1 , margin_right = 1 , margin_bottom = 1 , margin_left = 1 , plot_border_size=1 , plot_border_color="black" , ... ) { ## TODO: For the basic aesthetics (color, fill, alpha) ## Need to distinguish between column name and constant value ## ## --------------------------------------------- ## ## ERROR CHECK (this should be standard amongst all premade gg plot funcitons) ## --------------------------------------------- ## gg_confirm_aes_values(DT, c("label", "color", "fill", "shape")) # gg_confirm_aes_values(DT, c("label")) if ((!is.null(xscale) && !(xscale %in% gg_scale_functions)) || (!is.null(yscale) && !(yscale %in% gg_scale_functions))) stop (warningCols("xscale and yscale should be NULL or one of the following values:", gg_scale_functions)) facet_scales <- match.arg(facet_scales) if (!missing(legend_title_off)) { warning ("legend_title_off has been deprecated. Use legend_title_on instead", call.=FALSE) legend.fill_on <- legend_title_off } ## --------------------------------------------- ## ## CLEAN UP LABS ## --------------------------------------------- ## ## Remind user to add a title. All charts should have a title verboseMsg(missing(title), "Don't forget to add a title -- and perhaps title_append", time=FALSE, func="message") ## For some ungodly reason, if title is a call, it cannot be picked up and passed along with collectArgs ## Thus in previous functions, it is converted via capture.output and then marked for parsing title_is_call <- substitute(title) %>% is.call if (!title_is_call && (isTRUE(attr(title, "needs_parsing")) || (length(title) == 1 && grepl("atop|italic", title)))) title <- parse(text=title) if (missing(ylab)) { ylab <- gg_cleanColumnName(y) if (ylab=="Rows") ylab <- "Rows of Data" if (!is.null(yscale)) { if (grepl("percent", yscale)) ylab <- sprintf("%s (%%)", ylab) else if (grepl("log", yscale)) ylab <- sprintf("Log of %s", ylab) else if (!grepl("dollar", yscale) && !isTRUE(y_is_dollars)) ylab <- sprintf("%s (in %ss)", ylab, gsub("s$", "", yscale)) } } # if (!is.null(ylab_append)) # ylab <- paste0(ylab, "\n", ylab_append) ylab <- subtext(main=ylab, subtext=ylab_append, line3=ylab_line3) if (missing(xlab)) { xlab <- gg_cleanColumnName(x) if (!is.null(xscale)) { if (grepl("percent", xscale)) xlab <- sprintf("%s (%)", xlab) else if (grepl("log", yscale)) ylab <- sprintf("Log of %s", ylab) else if (!grepl("dollar", xscale) && !isTRUE(x_is_dollars)) xlab <- sprintf("%s (in %ss)", xlab, gsub("s$", "", xscale)) } } # if (!is.null(xlab_append)) # xlab <- paste0(xlab, "\n", xlab_append) xlab <- subtext(main=xlab, subtext=xlab_append, line3=xlab_line3) if (!is.null(title_append)) title <- paste0(title, "\n", title_append) # title <- subtext(title, title_append, body.sub="plain") ## Modify xlab and ylab based on facetting ## Determine if there are x/y facets. If so, we wil add a note to x/y_lab facet_has_free_xy <- doesFacetHaveXY(facet_formula) facet_has_free_xy$x <- facet_has_free_xy$x & facet_scales %in% c("free", "free_x") facet_has_free_xy$y <- facet_has_free_xy$y & facet_scales %in% c("free", "free_y") if (facet_has_free_xy$x) xlab <- subtext(main=xlab, subtext(main="", subtext="Note the different scales on each facet")) if (facet_has_free_xy$y) ylab <- subtext(main=ylab, line3=subtext(main="", subtext="", line3="Note the different scales on each facet")) # ylab <- subtext(main=ylab, subtext=" ", line3="Note the different scales on each facet") ## --------------------------------------------- ## browser(expr=inDebugMode("gg_GenericProcessing", "Generic"), text="in gg_GenericProcessing() right before aes color fill shape, after labs") ### -------------------------------------------------- #### ### -------------------------------- #### ### COLOR & FILL & SHAPE #### ### -------------------------------- #### if (!is.null(color)) { P <- P + aes_string(color=color) ## Add a name for the legend if (is.null(names(color))) names(color) <- gg_cleanColumnName(color) } if (!is.null(fill)) { P <- P + aes_string(fill=fill) ## Add a name for the legend if (is.null(names(fill))) names(fill) <- gg_cleanColumnName(fill) } if (!is.null(shape)) { P <- P + aes_string(shape=shape) ## Add a name for the legend if (is.null(names(shape))) names(shape) <- gg_cleanColumnName(shape) } if (!is.null(dict.colors)) { if (is.null(color)) stop ("cannot specifiy 'dict.colors' without specifying the 'color' column") ## TODO: Check that if (length(wh.colors.missing <- setdiff(unique(DT[[color]]), names(dict.colors)) )) warning (warningCols("There are unrepresented values for colors", wh.colors.missing)) P <- P + scale_color_manual(values=dict.colors, name=names(color)) } else if (!is.null(names(color))) { ## Different scaling function for discrete vs continuous column in DT if (is.numeric(DT[[color]])) P <- P + scale_color_continuous(name=names(color)) else P <- P + scale_color_discrete(name=names(color)) } if (!is.null(dict.fills)) { if (is.null(fill)) stop ("cannot specifiy 'dict.fills' without specifying the 'fill' column") ## TODO: Check that if (length(wh.fills.missing <- setdiff(unique(DT[[fill]]), names(dict.fills)) )) warning (warningCols("There are unrepresented values for fills", wh.fills.missing)) P <- P + scale_fill_manual(values=dict.fills, name=names(fill)) } else if (!is.null(names(fill))) { ## Different scaling function for discrete vs continuous column in DT if (is.numeric(DT[[fill]])) P <- P + scale_fill_continuous(name=names(fill)) else P <- P + scale_fill_discrete(name=names(fill)) } if (!is.null(dict.shapes)) { if (is.null(shape)) stop ("cannot specifiy 'dict.shapes' without specifying the 'shape' column") ## TODO: Check that if (length(wh.shapes.missing <- setdiff(unique(DT[[shape]]), names(dict.shapes)) )) warning (warningCols("There are unrepresented values for shapes", wh.shapes.missing)) P <- P + scale_shape_manual(values=dict.shapes, name=names(shape)) } else if (!is.null(names(shape))) { ## Different scaling function for discrete vs continuous column in DT if (is.numeric(DT[[shape]])) P <- P + scale_shape_continuous(name=names(shape)) else P <- P + scale_shape_discrete(name=names(shape)) } ### -------------------------------------------------- #### ## Scale each axis if (!is.null(yscale)) { scale.func.nm <- sprintf("%s.%s", yscale, "y") scale.func <- try(match.fun(scale.func.nm), silent=TRUE) if (isErr(scale.func)) warning("scale function '", scale.func.nm, "' not found") else P <- P + scale.func(limits=ylims, dollar=y_is_dollars) } else if (!is.null(ylims)) { P <- P + ylim(ylims) } if (!is.null(xscale)) { scale.func.nm <- sprintf("%s.%s", xscale, "x") scale.func <- try(match.fun(scale.func.nm), silent=TRUE) if (isErr(scale.func)) warning("scale function '", scale.func.nm, "' not found") else P <- P + scale.func(limits=xlims, dollar=x_is_dollars) } else if (!is.null(xlims)) { P <- P + xlim(xlims) } if (!is.null(label)) { ## NOTE: Since we are using 'get(label)' inside of the DT, if the DT has a column also named label, scoping will force the wrong label to be used. ## Thus, we are creating the new var ._label. ._label. <- copy(label) labelface <- match.arg(labelface) tmp_DT.label <- DT[!is.na(get(._label.))] ## 2015-08-30 :: This was set nrow >= 2, but not sure why; I'm setting it to >= 1. if (nrow(tmp_DT.label) >= 1) { label_shover <- function(z, scaler, lims=NULL, zeros_bump=!is_percent, is_percent=!is.date_or_time(z) && all(abs(z) < 2), na.rm=TRUE) { if (is.char_of_length1(z, showWarnings=FALSE, fail=FALSE)) z <- get(z) if (is.null(scaler) || scaler == 0) return(z) ## shove the 0's up to the 10% quantile if (zeros_bump) { zeros <- round(z, -1) == 0 ## Only bump up the zeros if it's less than half of the values if (sum(zeros) < (sum(!is.na(z)))/2) z[zeros] <- quantile(z[!zeros], .10) } ## Normally, add a fraction of the diff of the range; ## However don't use range(z) when faceting # if (!is.null(facet_formula)) # ret <- z + (z * scaler) # else # ret <- z + (diff(range(z)) * scaler) ret <- z %>% quantile(c(.12, .87)) %>% diff %>% {. * scaler + z} if (!is.null(lims)) { mxlim <- maxn(lims) ret[ret >= mxlim] <- mxlim * (1 - (.02) * sign(mxlim)) mnlim <- minn(lims) ret[ret <= mnlim] <- mnlim * (1 + (.02) * sign(mnlim)) } return(ret) } if (length(labelalpha) < length(labelcolor)) labelalpha <- rev(c(labelalpha, rep(0.3, length(labelcolor))))[seq(labelcolor)] # if (label_y_up) tmp_DT.label[, (y) := get(y) + (diff(range(get(y))) * label_y_up) ] # if (label_x_up) tmp_DT.label[, (x) := get(x) + (diff(range(get(x))) * label_x_up) ] by.x <- if (!is.null(facet_formula) && facet_scales %in% c("free", "free_x") && facet_x != ".") facet_x by.y <- if (!is.null(facet_formula) && facet_scales %in% c("free", "free_y") && facet_y != ".") facet_y if (label_y_up) tmp_DT.label[, (y) := label_shover(z=get(y), scaler=label_y_up, lims=ylims), by=by.x] if (label_x_up) tmp_DT.label[, (x) := label_shover(z=get(x), scaler=label_x_up, lims=xlims), by=by.y] for (i in unique(c(1, seq_along(labelcolor)))) { # cat(sprintf("%02i : alpha = %s, color = '%s' \n", i, labelalpha[[i]], ifelse(is.null(labelcolor[[i]]), "NULL", labelcolor[[i]] ))) ## I cant find a clean way to include color without redoing the whole line of code if (!is.null(labelcolor[[i]])) { if (labelcolor[[i]] %in% names(DT)) P <- P + geom_text(data=tmp_DT.label, aes_string(label=._label.), size=labelsize * (1 -(i-1)*.02), fontface=labelface, position=position_jitter(w=labeljitter_x, h=labeljitter_y), alpha=labelalpha[[i]], show.legend = FALSE) else P <- P + geom_text(data=tmp_DT.label, aes_string(label=._label., color=labelcolor[[i]]), size=labelsize * (1 -(i-1)*.02), fontface=labelface, position=position_jitter(w=labeljitter_x, h=labeljitter_y), alpha=labelalpha[[i]], show.legend = FALSE, color=labelcolor[[i]]) } else P <- P + geom_text(data=tmp_DT.label, aes_string(label=._label.), size=labelsize * (1 -(i-1)*.02), fontface=labelface, position=position_jitter(w=labeljitter_x, h=labeljitter_y), alpha=labelalpha[[i]], show.legend = FALSE) } } # ## using geom_dl # # P + directlabels::geom_dl(aes_string(label="date"), method="top.qp") # if (!is.null(labelcolor)) # P <- P + geom_text(data=DT[!is.na(get(._label.))][, (y) := get(y) + diff(range(total_streams)) / 25 ], aes_string(label=._label.), size=labelsize, fontface=labelface, position=position_jitter(w=labeljitter_x, h=labeljitter_y), color=labelcolor) # else # P <- P + geom_text(data=DT[!is.na(get(._label.))][, (y) := get(y) + diff(range(total_streams)) / 25 ], aes_string(label=._label.), size=labelsize, fontface=labelface, position=position_jitter(w=labeljitter_x, h=labeljitter_y)) } ## Add axis and plot labs P <- P + labs(x=xlab, y=ylab) + ggtitle(title) + theme(plot.title=element_text(size=rel(title_size_rel))) + angledtext(x=x_angledtext, y=y_angledtext) + relativetext(x=x_relativetitle, y=y_relativetitle, what="title") + relativetext(x=x_relativetext, y=y_relativetext, what="text") + ## facet relativetext(x=x_facet_relative_text, what="facet_x") + relativetext(y=y_facet_relative_text, what="facet_y") ## Add vline if (!is.null(vline_value)) { ## If DT$x is a date/time, convert the value to numeric if (is.date_or_time(DT[[x]])) { if (is.Date(DT[[x]]) && !is.Date(vline_value)) vline_value <- as.Date(vline_value, origin=.origin) if (is.POSIXct(DT[[x]]) && !is.POSIXct(vline_value)) vline_value <- as.POIXct(vline_value, origin=.origin.utc) if (is.POSIXlt(DT[[x]]) && !is.POSIXlt(vline_value)) vline_value <- as.POIXlt(vline_value, origin=.origin.utc) vline_value <- as.numeric(vline_value) } P <- P + geom_vline(xintercept=vline_value, alpha=vline_alpha, color=vline_color, linetype=6, size=vline_thickness) } ## Add hline if (!is.null(hline_value)) { ## If DT$y is a date/time, convert the value to numeric if (is.date_or_time(DT[[y]])) { if (is.Date(DT[[y]]) && !is.Date(hline_value)) hline_value <- as.Date(hline_value, origin=.origin) if (is.POSIXct(DT[[y]]) && !is.POSIXct(hline_value)) hline_value <- as.POIXct(hline_value, origin=.origin.utc) if (is.POSIXlt(DT[[y]]) && !is.POSIXlt(hline_value)) hline_value <- as.POIXlt(hline_value, origin=.origin.utc) hline_value <- as.numeric(hline_value) } P <- P + geom_hline(yintercept=hline_value, alpha=hline_alpha, color=hline_color, linetype=6, size=hline_thickness) } ## Set Legend { legend <- match.arg(legend) if (legend == "off") P <- P + theme(legend.position="none") else if (isTRUE(legend_title_on)) P <- P + theme(legend.position=legend, legend.key=element_rect(size=rel(legend_key_size_rel)), legend.text=element_text(size=rel(legend_font_size_rel))) else P <- P + theme(legend.position=legend, legend.key=element_rect(size=rel(legend_key_size_rel)), legend.text=element_text(size=rel(legend_font_size_rel)), legend.title = element_blank()) } ## margins; use margin_scale as an indicator as to whether or not to manually override automargins if (!is.null(margin_scale)) { P <- P + theme(plot.margin = unit(x=margins, units=margin_units)) } ## plot border: use plot_border_size as an indicator as to whether or not to set if (plot_border_size > 0) { P <- P + theme(panel.border = element_rect(colour=plot_border_color, fill=NA, size=plot_border_size)) } ## Facet if (!is.null(facet_formula)) { P <- P + facet_grid(as.formula(facet_formula), scales=facet_scales) } ## guides can have a value of FALSE / NULL (or other such as guide_legedn()) ## NULL acts like TRUE. TRUE however causes an error. Hence the cumbersome "if(FALSE) FALSE" with an implicit "else NULL" P <- P + guides(fill=if(!isTRUE(legend.fill_on)) FALSE, shape=if(!isTRUE(legend.shape_on)) FALSE, color=if(!isTRUE(legend.color_on)) FALSE, alpha=if(!isTRUE(legend.alpha_on)) FALSE, linetype=if(!isTRUE(legend.linetype_on)) FALSE, size=if(!isTRUE(legend.size_on)) FALSE) return(P) } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # gg_findScaleAutomatically <- function(vec, nm.vec=substitute(vec), DT=NULL, percent.allowed=!dollar, dollar=FALSE) { ## A return of NULL means do NOT scale ## Otherwise, this will choose between percent, thousands, millions, billions ## dollar :: If TRUE, then user is indicating that vec is known to be a currency value if (missing(vec) && !missing(nm.vec) && (is.data.frame(DT) || is.list(DT))) vec <- DT[[nm.vec]] ## if not a number or no length, do not scale if (!is.numeric(vec) || !length(vec)) return (NULL) ## convert numbers to absolute to make comparisons simpler vec <- abs(vec) # if (!is.vector(vec)) # stop ("vec should be a vector") ## TODO: Change this to detectPercentColumns, but needs nm.vec ## Count how many are between 0 and 1 ## The threshold is dramatically dropped if the name contains "perc" thresh.for.perc <- ifelse(grepl("perc|%", capture.output(nm.vec)), 0.30, 0.90) if (percent.allowed && is.perc(vec) || (sum(0 < vec & vec < 1, na.rm=TRUE) / length(vec) >= thresh.for.perc)) return("percent") if (maxn(vec) > 1e9) return("billions") if (maxn(vec) > 1e6) return("millions") if (maxn(vec) > 1e3) return("thousands") return(NULL) }