R/GraphCleaning.r
In USEPA/micromap: Linked Micromap Plots
Defines functions
assimilatePlot
axis_opts
graph_opts
plot_opts
##########################
##### theme settings #####
##########################
# creating theme functions to be called as needed from the panel building done elsewhere
# each function takes a ggplot object (e.g. pl <- plots[[1]]) and adds attributes to it
# as specified in the above function arguments then returns the object
### set panel background color, overall title and margins
#' @export
plot_opts <- function(i, pl, a){
# sets background color if specified
if(!is.na(a[[i]]$panel.bgcolor)) pl <- pl + theme(plot.background = element_rect(colour=a[[i]]$panel.bgcolor,
fill=a[[i]]$panel.bgcolor))
# sets a header title if specified
# if any of the panels have a header this inserts a blank title on those that do not in order
# to keep a similar layout among panels
if(!all(is.na(all_atts(a, 'panel.header')))){
tmp.size <- max(as.numeric(all_atts(a, 'panel.header.size')))*10 # All headers must be same size. Default size is 10
tmp.lineheight <- as.numeric(all_atts(a, 'panel.header.lineheight'))
tmp.lineheight <- tmp.lineheight[which.max(abs(tmp.lineheight-1))] # All line heights must be equal so we use the height
# most drastically different from 1
# If all headers aren't NA then we must change the titles to be blank in order to leave space
# for them at the top. If any header is multiple lines (ie contains '\n') then we must add in
# the correct number of character returns to the other headers in order to make the plot uniform
tmp.headers <- lapply(all_atts(a, 'panel.header'), function(t) if(is.na(t)|t=='') t=' ' else t)
tmp.title <- tmp.headers[[i]]
ns <- max(unlist(lapply(tmp.headers, function(x) length(strsplit(x, '\n')[[1]])))) - length(strsplit(tmp.title,'\n')[[1]])
if(ns>0) tmp.title <- paste(tmp.title, rep(' \n ',ns), sep='')
pl <- pl + ggtitle(tmp.title) +
theme(plot.title=element_text(family=a[[i]]$panel.header.font, face=a[[i]]$panel.header.face,
colour=a[[i]]$panel.header.color, size=tmp.size, lineheight=tmp.lineheight, hjust = 0.5))
}
# sets panel margins and removes ggplot's default side strips
pl <- pl + theme(strip.background = element_blank(),
strip.text.x = element_blank(),
strip.text.y = element_blank(),
plot.margin = unit(a[[i]]$panel.margins, "lines"))
pl
}
### set graph background color and whether grid lines show up
#' @export
graph_opts <- function(i, pl, a){
bgcolor <- ifelse(!is.na(a[[i]]$panel.bgcolor), a[[i]]$panel.bgcolor, 'white')
bgcolor <- ifelse(!is.na(a[[i]]$graph.bgcolor), a[[i]]$graph.bgcolor, bgcolor)
# sets background color of graphs
# note: what were referring to as "graphs" are what ggplot refers to as "panels" (ie. "panel.background")
pl <- pl + theme(panel.background = element_rect(colour=bgcolor, fill=bgcolor))
# draws grid lines in the specified color if desired -- defaults to darkgray in attribute list
if(a[[i]]$graph.grid.major){
pl <- pl + theme(panel.grid.major = element_line(colour=a[[i]]$graph.grid.color))
} else {
pl <- pl + theme(panel.grid.major = element_blank())
}
if(a[[i]]$graph.grid.minor){
pl <- pl + theme(panel.grid.minor = element_line(colour=a[[i]]$graph.grid.color))
} else {
pl <- pl + theme(panel.grid.minor = element_blank())
}
pl
}
### sets graph boundaries, ticks, labels, borders
#' @export
axis_opts <- function(i, pl, a, limsx=NA, limsy=NA, border=TRUE, expx=FALSE){
# i=p; a=att; limsx=tmp.limsx; limsy=c(tmp.limsy,tmp.median.limsy); border=FALSE; expx=FALSE
# many features are "hidden" by simply coloring the same color as the background so
# if panel background is NA we assume "white" will effectively do the hiding
bgcolor <- ifelse(!is.na(a[[i]]$panel.bgcolor), a[[i]]$panel.bgcolor, 'white')
# specify label size as maximum of all requested label sizes
label.size <- as.numeric(max(all_atts(a, 'xaxis.labels.size')))*10
# limsy will sometimes be in the form (c(lower bound, upper bound, lower bound for the median , upper bound for the median))
# if thats the case, we split it into the two seperate limits here
median.limsy <- NULL
if(length(limsy)==4) {median.limsy <- limsy[3:4]; limsy <- limsy[1:2]}
##############
### X axis ###
##############
# with ggplot2, most axis specifications need to be made through the "scale_x_continuous()" function. there
# are 5 arguements: title, breaks (tick locations), labels (tick labels), limits (data limits), and expand (the
# extent to which the axis is expanded beyond the limits of the data). these specifications must be made
# all at once so we build this statement as a string and then execute it through an "eval" statement at the end
# the following boolean variables state whether to include these specifications in the scale_x_continuous statement
# we start by assuming none except title will be needed
x.breaks <- x.labels <- x.limits <- x.expand <- FALSE
### axis title ###
xstr.title <- "''"
# If all axis titles aren't NA then we must change the other titles to be blank in order to leave space
# for them at the bottom. If any title is multiple lines (ie contains '\n') then we must add in
# the correct number of character returns to the other titles in order to make the plot uniform
if(!all(is.na(all_atts(a, 'xaxis.title')))){
tmp.size <- max(as.numeric(all_atts(a, 'xaxis.title.size')))*8 # All titles must be same size. Default size is 8
tmp.lineheight <- as.numeric(all_atts(a, 'xaxis.title.lineheight'))
tmp.lineheight <- tmp.lineheight[which.max(abs(tmp.lineheight-1))] # All line heights must be equal so we use the height
# most drastically different from 1
tmp.titles <- lapply(all_atts(a, 'xaxis.title'), function(t) if(is.na(t)|t=='') t=' ' else t)
tmp.title <- tmp.titles[[i]]
ns <- max(unlist(lapply(tmp.titles, function(x) length(strsplit(x, '\n')[[1]])))) - length(strsplit(tmp.title,'\n')[[1]])
if(ns>0) tmp.title <- paste(tmp.title, rep(' \n ',ns), sep='')
xstr.title <- paste("'",tmp.title,"'",sep='')
pl <- pl + theme(axis.title.x = element_text(family=a[[i]]$xaxis.title.font, face=a[[i]]$xaxis.title.face,
colour=a[[i]]$xaxis.title.color, size=tmp.size, lineheight=tmp.lineheight))
}
### axis limits and expansion ###
if (!any(is.na(limsx))) x.limits <- TRUE
# if there is a border to be added, we must manually deal with expansion
if(!expx){
x.expand <- TRUE
xstr.expand <- as.character(", expand=c(0,0)")
}
xstr.limits <- as.character(paste('c(',min(limsx), ',', max(limsx),')'))
xstr.limits <- paste(", limits=", xstr.limits)
### panel footers (not completed) ###
# "panel footers" are really just augmented x axis titles
# if all axis titles are blank then we hide axis titles on the whole plot
if(all(is.na(all_atts(a, 'xaxis.title')))) pl <- pl + theme(axis.title.x = element_blank())
### axis lines ###
# note: axis lines are always there, if the user doesn't want to
# see them they are colored to match the background
if (!a[[i]]$xaxis.line.display & !a[[i]]$yaxis.line.display) {
pl <- pl + theme(axis.line = element_line(colour=bgcolor))
# else lines will be plotted
} else {
pl <- pl + theme(axis.line = element_line(colour='black'))
}
### axis ticks ###
# for now we assume ticks are never wanted as they make things pretty cluttered looking
pl <- pl + theme(axis.ticks = element_blank())
### axis text ###
# trys to hide axis text on the whole plot
if(!any(all_attsb(a, 'xaxis.text.display'))) {
pl <- pl + theme(axis.text.x = element_blank())
# otherwise trys to "hide" axis text on this panel
} else if (!a[[i]]$xaxis.text.display) {
pl <- pl + theme(axis.text.x = element_text(colour=bgcolor, size=label.size))
# axis text will show and we'll add specific labels if requested
} else if (!is.na(unlist(a[[i]]$xaxis.labels)[1]) &
!is.na(unlist(a[[i]]$xaxis.ticks)[1])) {
tmpTheme <- "theme(axis.text.x = element_text(size=label.size"
if(!is.null(a[[i]]$xaxis.labels.angle)) tmpTheme <- paste(tmpTheme, ", angle = ", a[[i]]$xaxis.labels.angle)
if(!is.null(a[[i]]$xaxis.labels.hjust)) tmpTheme <- paste(tmpTheme, ", hjust =", a[[i]]$xaxis.labels.hjust)
if(!is.null(a[[i]]$xaxis.labels.vjust)) tmpTheme <- paste(tmpTheme, ", vjust =", a[[i]]$xaxis.labels.vjust)
tmpTheme <- paste(tmpTheme, "))")
pl <- pl + eval(parse(text=tmpTheme ))
x.breaks <- x.labels <- TRUE
xstr.breaks <- paste(', breaks=c(', make.string(a[[i]]$xaxis.ticks),')',sep='')
xstr.labels <- paste(', labels=c(', make.string(a[[i]]$xaxis.labels),')',sep='')
# warning if user only specified text but not location or vice versa
} else if (!is.na(unlist(a[[i]]$xaxis.labels)[1]) |
!is.na(unlist(a[[i]]$xaxis.ticks)[1])) {
print('Warning: both axis labels AND tick location must be specified')
# otherwise text shows up as ggplot defaults
}
# transformation string
xstr.trans <- paste0(', trans = ', a[[i]]$trans)
xstr <- paste("scale_x_continuous(", xstr.title, xstr.trans)
if (x.expand) xstr <- paste(xstr, xstr.expand)
if (x.breaks) xstr <- paste(xstr, xstr.breaks)
if (x.labels) xstr <- paste(xstr, xstr.labels)
if (x.limits) xstr <- paste(xstr, xstr.limits)
xstr <- paste(xstr, ")")
pl <- pl + eval(parse(text=xstr))
##############
### Y axis ###
##############
# with ggplot2, most axis specifications need to be made through the "scale_y_continuous()" function. there
# are 5 arguements: title, breaks (tick locations), labels (tick labels), limits (data limits), and expand (the
# extent to which the axis is expanded beyond the limits of the data). these specifications must be made
# all at once so we build this statement as a string and then execute it through an "eval" statement at the end
### axis title ###
ystr.title <- ifelse(!is.na(a[[i]]$yaxis.title), a[[i]]$yaxis.title, "''")
### axis text ###
if(a[[i]]$yaxis.ticks.display | a[[i]]$yaxis.text.display) ystr.breaks <- "" else ystr.breaks <- ", breaks=NULL"
### axis limits and expansion ###
ystr.expand <- ", expand=c(0,0)"
limsy <- limsy + c(-1,1) * diff(limsy)*a$plot.pGrp.spacing
ystr.limits <- as.character(paste('c(',min(limsy), ',', max(limsy),')'))
ystr.limits <- paste(", limits=", ystr.limits)
pl <- pl + theme(panel.spacing = unit(0, "lines"))
# if (any(is.na(limsy)) | a$median.row) y.limits <- FALSE else y.limits <- TRUE
# put it all together and execute the eval call
ystr <- paste("scale_y_continuous(", ystr.title, ystr.expand, ystr.breaks)
# if (y.limits) ystr <- paste(ystr, ystr.limits)
ystr <- paste(ystr, ")")
pl <- pl + eval(parse(text=ystr))
##############
### border ###
##############
borderx <- range(limsx) + c(1,-1) * diff(range(limsx))*.001
bordery <- range(limsy) + c(0, -1) * diff(range(limsy))*.001
if(!is.null(median.limsy)) median.limsy <- range(median.limsy) - c(0, diff(range(median.limsy))*.001)
tmp.border <- data.frame(pGrp=rep(1:max(pl$data$pGrp),each=2), ymin=bordery[1], ymax=bordery[2],
xmin=borderx[1], xmax=borderx[2])
if(a$median.row) tmp.border <- rbind(subset(tmp.border, !pGrp==a$m.pGrp), data.frame(pGrp=a$m.pGrp, ymin=median.limsy[1], ymax=median.limsy[2],
xmin=borderx[1], xmax=borderx[2]))
if(border) border.color <- a[[i]]$graph.border.color else border.color <- NA
pl <- pl + geom_rect(aes(xmin = xmin, xmax=xmax, ymin=ymin, ymax=ymax), data=tmp.border,
colour= border.color, fill=NA)
pl <- pl + theme(axis.line = element_blank())
pl
}
#' Cleans a User Made Panel
#'
#' Sends a user made panel out to the graph "cleaning functions" in lmplot in
#' order to properly display a user made panel seemlessly into the rest of an
#' lmplot.
#'
#'
#' @param pl the lmplot object.
#' @param i the panel number.
#' @param a the attribute list.
#' @param limsx limits of the x axis if desired.
#' @param limsy limits of the y axis if desired.
#' @return Returns a cleaned plot object.
#' @note See the Introduction Guide for a full list of the options available
#' for altering micromaps.
#' @author Quinn Payton \email{Payton.Quinn@@epa.gov}
#' @export assimilatePlot
assimilatePlot <- function(pl, i, a, limsx=NA, limsy=NA){
pl <- plot_opts(i,pl,a)
pl <- graph_opts(i,pl,a)
if(any(is.na(limsx))){
limsx <- range(pl$data[,unlist(a[[i]]$panel.data)])
limsx <- limsx+c(-1,1)*diff(limsx)*.05
}
if(any(is.na(limsy))){
# labs <- names(pl$options$labels)
# labs <- labs[sapply(1:length(labs), function(j) pmatch("y",labs[j], nomatch=0)==1)]
# limsy <- -range(pl$data[,sub("-","",unlist(pl$options$labels[labs]))])
# limsy <- limsy + c(1,-1)*diff(limsy)*.05
limsy <- -c(.5, max(a$grouping)+.5)
}
if(a$median.row){
pl <- suppressMessages({pl + scale_colour_manual(values=c(a$colors,gray(.5)), guide='none')})
median.limsy <- c(-.5, -1.5)
limsy <- c(limsy, median.limsy)
}
pl <- axis_opts(i,pl,a, limsx=limsx, limsy=limsy, border=TRUE)
pl
}
USEPA/micromap documentation built on Sept. 18, 2024, 11:46 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions assimilatePlot axis_opts graph_opts plot_opts
##########################
##### theme settings #####
##########################
# creating theme functions to be called as needed from the panel building done elsewhere
# each function takes a ggplot object (e.g. pl <- plots[[1]]) and adds attributes to it
# as specified in the above function arguments then returns the object
### set panel background color, overall title and margins
#' @export
plot_opts <- function(i, pl, a){
# sets background color if specified
if(!is.na(a[[i]]$panel.bgcolor)) pl <- pl + theme(plot.background = element_rect(colour=a[[i]]$panel.bgcolor,
fill=a[[i]]$panel.bgcolor))
# sets a header title if specified
# if any of the panels have a header this inserts a blank title on those that do not in order
# to keep a similar layout among panels
if(!all(is.na(all_atts(a, 'panel.header')))){
tmp.size <- max(as.numeric(all_atts(a, 'panel.header.size')))*10 # All headers must be same size. Default size is 10
tmp.lineheight <- as.numeric(all_atts(a, 'panel.header.lineheight'))
tmp.lineheight <- tmp.lineheight[which.max(abs(tmp.lineheight-1))] # All line heights must be equal so we use the height
# most drastically different from 1
# If all headers aren't NA then we must change the titles to be blank in order to leave space
# for them at the top. If any header is multiple lines (ie contains '\n') then we must add in
# the correct number of character returns to the other headers in order to make the plot uniform
tmp.headers <- lapply(all_atts(a, 'panel.header'), function(t) if(is.na(t)|t=='') t=' ' else t)
tmp.title <- tmp.headers[[i]]
ns <- max(unlist(lapply(tmp.headers, function(x) length(strsplit(x, '\n')[[1]])))) - length(strsplit(tmp.title,'\n')[[1]])
if(ns>0) tmp.title <- paste(tmp.title, rep(' \n ',ns), sep='')
pl <- pl + ggtitle(tmp.title) +
theme(plot.title=element_text(family=a[[i]]$panel.header.font, face=a[[i]]$panel.header.face,
colour=a[[i]]$panel.header.color, size=tmp.size, lineheight=tmp.lineheight, hjust = 0.5))
}
# sets panel margins and removes ggplot's default side strips
pl <- pl + theme(strip.background = element_blank(),
strip.text.x = element_blank(),
strip.text.y = element_blank(),
plot.margin = unit(a[[i]]$panel.margins, "lines"))
pl
}
### set graph background color and whether grid lines show up
#' @export
graph_opts <- function(i, pl, a){
bgcolor <- ifelse(!is.na(a[[i]]$panel.bgcolor), a[[i]]$panel.bgcolor, 'white')
bgcolor <- ifelse(!is.na(a[[i]]$graph.bgcolor), a[[i]]$graph.bgcolor, bgcolor)
# sets background color of graphs
# note: what were referring to as "graphs" are what ggplot refers to as "panels" (ie. "panel.background")
pl <- pl + theme(panel.background = element_rect(colour=bgcolor, fill=bgcolor))
# draws grid lines in the specified color if desired -- defaults to darkgray in attribute list
if(a[[i]]$graph.grid.major){
pl <- pl + theme(panel.grid.major = element_line(colour=a[[i]]$graph.grid.color))
} else {
pl <- pl + theme(panel.grid.major = element_blank())
}
if(a[[i]]$graph.grid.minor){
pl <- pl + theme(panel.grid.minor = element_line(colour=a[[i]]$graph.grid.color))
} else {
pl <- pl + theme(panel.grid.minor = element_blank())
}
pl
}
### sets graph boundaries, ticks, labels, borders
#' @export
axis_opts <- function(i, pl, a, limsx=NA, limsy=NA, border=TRUE, expx=FALSE){
# i=p; a=att; limsx=tmp.limsx; limsy=c(tmp.limsy,tmp.median.limsy); border=FALSE; expx=FALSE
# many features are "hidden" by simply coloring the same color as the background so
# if panel background is NA we assume "white" will effectively do the hiding
bgcolor <- ifelse(!is.na(a[[i]]$panel.bgcolor), a[[i]]$panel.bgcolor, 'white')
# specify label size as maximum of all requested label sizes
label.size <- as.numeric(max(all_atts(a, 'xaxis.labels.size')))*10
# limsy will sometimes be in the form (c(lower bound, upper bound, lower bound for the median , upper bound for the median))
# if thats the case, we split it into the two seperate limits here
median.limsy <- NULL
if(length(limsy)==4) {median.limsy <- limsy[3:4]; limsy <- limsy[1:2]}
##############
### X axis ###
##############
# with ggplot2, most axis specifications need to be made through the "scale_x_continuous()" function. there
# are 5 arguements: title, breaks (tick locations), labels (tick labels), limits (data limits), and expand (the
# extent to which the axis is expanded beyond the limits of the data). these specifications must be made
# all at once so we build this statement as a string and then execute it through an "eval" statement at the end
# the following boolean variables state whether to include these specifications in the scale_x_continuous statement
# we start by assuming none except title will be needed
x.breaks <- x.labels <- x.limits <- x.expand <- FALSE
### axis title ###
xstr.title <- "''"
# If all axis titles aren't NA then we must change the other titles to be blank in order to leave space
# for them at the bottom. If any title is multiple lines (ie contains '\n') then we must add in
# the correct number of character returns to the other titles in order to make the plot uniform
if(!all(is.na(all_atts(a, 'xaxis.title')))){
tmp.size <- max(as.numeric(all_atts(a, 'xaxis.title.size')))*8 # All titles must be same size. Default size is 8
tmp.lineheight <- as.numeric(all_atts(a, 'xaxis.title.lineheight'))
tmp.lineheight <- tmp.lineheight[which.max(abs(tmp.lineheight-1))] # All line heights must be equal so we use the height
# most drastically different from 1
tmp.titles <- lapply(all_atts(a, 'xaxis.title'), function(t) if(is.na(t)|t=='') t=' ' else t)
tmp.title <- tmp.titles[[i]]
ns <- max(unlist(lapply(tmp.titles, function(x) length(strsplit(x, '\n')[[1]])))) - length(strsplit(tmp.title,'\n')[[1]])
if(ns>0) tmp.title <- paste(tmp.title, rep(' \n ',ns), sep='')
xstr.title <- paste("'",tmp.title,"'",sep='')
pl <- pl + theme(axis.title.x = element_text(family=a[[i]]$xaxis.title.font, face=a[[i]]$xaxis.title.face,
colour=a[[i]]$xaxis.title.color, size=tmp.size, lineheight=tmp.lineheight))
}
### axis limits and expansion ###
if (!any(is.na(limsx))) x.limits <- TRUE
# if there is a border to be added, we must manually deal with expansion
if(!expx){
x.expand <- TRUE
xstr.expand <- as.character(", expand=c(0,0)")
}
xstr.limits <- as.character(paste('c(',min(limsx), ',', max(limsx),')'))
xstr.limits <- paste(", limits=", xstr.limits)
### panel footers (not completed) ###
# "panel footers" are really just augmented x axis titles
# if all axis titles are blank then we hide axis titles on the whole plot
if(all(is.na(all_atts(a, 'xaxis.title')))) pl <- pl + theme(axis.title.x = element_blank())
### axis lines ###
# note: axis lines are always there, if the user doesn't want to
# see them they are colored to match the background
if (!a[[i]]$xaxis.line.display & !a[[i]]$yaxis.line.display) {
pl <- pl + theme(axis.line = element_line(colour=bgcolor))
# else lines will be plotted
} else {
pl <- pl + theme(axis.line = element_line(colour='black'))
}
### axis ticks ###
# for now we assume ticks are never wanted as they make things pretty cluttered looking
pl <- pl + theme(axis.ticks = element_blank())
### axis text ###
# trys to hide axis text on the whole plot
if(!any(all_attsb(a, 'xaxis.text.display'))) {
pl <- pl + theme(axis.text.x = element_blank())
# otherwise trys to "hide" axis text on this panel
} else if (!a[[i]]$xaxis.text.display) {
pl <- pl + theme(axis.text.x = element_text(colour=bgcolor, size=label.size))
# axis text will show and we'll add specific labels if requested
} else if (!is.na(unlist(a[[i]]$xaxis.labels)[1]) &
!is.na(unlist(a[[i]]$xaxis.ticks)[1])) {
tmpTheme <- "theme(axis.text.x = element_text(size=label.size"
if(!is.null(a[[i]]$xaxis.labels.angle)) tmpTheme <- paste(tmpTheme, ", angle = ", a[[i]]$xaxis.labels.angle)
if(!is.null(a[[i]]$xaxis.labels.hjust)) tmpTheme <- paste(tmpTheme, ", hjust =", a[[i]]$xaxis.labels.hjust)
if(!is.null(a[[i]]$xaxis.labels.vjust)) tmpTheme <- paste(tmpTheme, ", vjust =", a[[i]]$xaxis.labels.vjust)
tmpTheme <- paste(tmpTheme, "))")
pl <- pl + eval(parse(text=tmpTheme ))
x.breaks <- x.labels <- TRUE
xstr.breaks <- paste(', breaks=c(', make.string(a[[i]]$xaxis.ticks),')',sep='')
xstr.labels <- paste(', labels=c(', make.string(a[[i]]$xaxis.labels),')',sep='')
# warning if user only specified text but not location or vice versa
} else if (!is.na(unlist(a[[i]]$xaxis.labels)[1]) |
!is.na(unlist(a[[i]]$xaxis.ticks)[1])) {
print('Warning: both axis labels AND tick location must be specified')
# otherwise text shows up as ggplot defaults
}
# transformation string
xstr.trans <- paste0(', trans = ', a[[i]]$trans)
xstr <- paste("scale_x_continuous(", xstr.title, xstr.trans)
if (x.expand) xstr <- paste(xstr, xstr.expand)
if (x.breaks) xstr <- paste(xstr, xstr.breaks)
if (x.labels) xstr <- paste(xstr, xstr.labels)
if (x.limits) xstr <- paste(xstr, xstr.limits)
xstr <- paste(xstr, ")")
pl <- pl + eval(parse(text=xstr))
##############
### Y axis ###
##############
# with ggplot2, most axis specifications need to be made through the "scale_y_continuous()" function. there
# are 5 arguements: title, breaks (tick locations), labels (tick labels), limits (data limits), and expand (the
# extent to which the axis is expanded beyond the limits of the data). these specifications must be made
# all at once so we build this statement as a string and then execute it through an "eval" statement at the end
### axis title ###
ystr.title <- ifelse(!is.na(a[[i]]$yaxis.title), a[[i]]$yaxis.title, "''")
### axis text ###
if(a[[i]]$yaxis.ticks.display | a[[i]]$yaxis.text.display) ystr.breaks <- "" else ystr.breaks <- ", breaks=NULL"
### axis limits and expansion ###
ystr.expand <- ", expand=c(0,0)"
limsy <- limsy + c(-1,1) * diff(limsy)*a$plot.pGrp.spacing
ystr.limits <- as.character(paste('c(',min(limsy), ',', max(limsy),')'))
ystr.limits <- paste(", limits=", ystr.limits)
pl <- pl + theme(panel.spacing = unit(0, "lines"))
# if (any(is.na(limsy)) | a$median.row) y.limits <- FALSE else y.limits <- TRUE
# put it all together and execute the eval call
ystr <- paste("scale_y_continuous(", ystr.title, ystr.expand, ystr.breaks)
# if (y.limits) ystr <- paste(ystr, ystr.limits)
ystr <- paste(ystr, ")")
pl <- pl + eval(parse(text=ystr))
##############
### border ###
##############
borderx <- range(limsx) + c(1,-1) * diff(range(limsx))*.001
bordery <- range(limsy) + c(0, -1) * diff(range(limsy))*.001
if(!is.null(median.limsy)) median.limsy <- range(median.limsy) - c(0, diff(range(median.limsy))*.001)
tmp.border <- data.frame(pGrp=rep(1:max(pl$data$pGrp),each=2), ymin=bordery[1], ymax=bordery[2],
xmin=borderx[1], xmax=borderx[2])
if(a$median.row) tmp.border <- rbind(subset(tmp.border, !pGrp==a$m.pGrp), data.frame(pGrp=a$m.pGrp, ymin=median.limsy[1], ymax=median.limsy[2],
xmin=borderx[1], xmax=borderx[2]))
if(border) border.color <- a[[i]]$graph.border.color else border.color <- NA
pl <- pl + geom_rect(aes(xmin = xmin, xmax=xmax, ymin=ymin, ymax=ymax), data=tmp.border,
colour= border.color, fill=NA)
pl <- pl + theme(axis.line = element_blank())
pl
}
#' Cleans a User Made Panel
#'
#' Sends a user made panel out to the graph "cleaning functions" in lmplot in
#' order to properly display a user made panel seemlessly into the rest of an
#' lmplot.
#'
#'
#' @param pl the lmplot object.
#' @param i the panel number.
#' @param a the attribute list.
#' @param limsx limits of the x axis if desired.
#' @param limsy limits of the y axis if desired.
#' @return Returns a cleaned plot object.
#' @note See the Introduction Guide for a full list of the options available
#' for altering micromaps.
#' @author Quinn Payton \email{Payton.Quinn@@epa.gov}
#' @export assimilatePlot
assimilatePlot <- function(pl, i, a, limsx=NA, limsy=NA){
pl <- plot_opts(i,pl,a)
pl <- graph_opts(i,pl,a)
if(any(is.na(limsx))){
limsx <- range(pl$data[,unlist(a[[i]]$panel.data)])
limsx <- limsx+c(-1,1)*diff(limsx)*.05
}
if(any(is.na(limsy))){
# labs <- names(pl$options$labels)
# labs <- labs[sapply(1:length(labs), function(j) pmatch("y",labs[j], nomatch=0)==1)]
# limsy <- -range(pl$data[,sub("-","",unlist(pl$options$labels[labs]))])
# limsy <- limsy + c(1,-1)*diff(limsy)*.05
limsy <- -c(.5, max(a$grouping)+.5)
}
if(a$median.row){
pl <- suppressMessages({pl + scale_colour_manual(values=c(a$colors,gray(.5)), guide='none')})
median.limsy <- c(-.5, -1.5)
limsy <- c(limsy, median.limsy)
}
pl <- axis_opts(i,pl,a, limsx=limsx, limsy=limsy, border=TRUE)
pl
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.