Created
May 30, 2013 01:04
-
-
Save dmarcelinobr/5675117 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#------------------------------------------------------------------------------- | |
# Generic panel border (can set any combination of left/right/top/bottom) | |
#------------------------------------------------------------------------------- | |
theme_border <- function( | |
type = c("left", "right", "bottom", "top", "none"), | |
colour = "black", size = 1, linetype = 1) { | |
# use with e.g.: ggplot(...) + opts( panel.border=theme_border(type=c("bottom","left")) ) + ... | |
type <- match.arg(type, several.ok=TRUE) | |
structure( | |
list(type = type, colour = colour, size = size, linetype = linetype), | |
class = c("theme_border", "element_blank", "element") | |
) | |
} | |
element_grob.theme_border <- function( | |
element, x = 0, y = 0, width = 1, height = 1, | |
type = NULL, | |
colour = NULL, size = NULL, linetype = NULL, | |
...) { | |
if (is.null(type)) type = element$type | |
xlist <- c() | |
ylist <- c() | |
idlist <- c() | |
if ("bottom" %in% type) { # bottom | |
xlist <- append(xlist, c(x, x+width)) | |
ylist <- append(ylist, c(y, y)) | |
idlist <- append(idlist, c(1,1)) | |
} | |
if ("top" %in% type) { # top | |
xlist <- append(xlist, c(x, x+width)) | |
ylist <- append(ylist, c(y+height, y+height)) | |
idlist <- append(idlist, c(2,2)) | |
} | |
if ("left" %in% type) { # left | |
xlist <- append(xlist, c(x, x)) | |
ylist <- append(ylist, c(y, y+height)) | |
idlist <- append(idlist, c(3,3)) | |
} | |
if ("right" %in% type) { # right | |
xlist <- append(xlist, c(x+width, x+width)) | |
ylist <- append(ylist, c(y, y+height)) | |
idlist <- append(idlist, c(4,4)) | |
} | |
if (length(type)==0 || "none" %in% type) { # blank; cannot pass absence of coordinates, so pass a single point and use an invisible line | |
xlist <- c(x,x) | |
ylist <- c(y,y) | |
idlist <- c(5,5) | |
linetype <- "blank" | |
} | |
gp <- gpar(lwd = len0_null(size * .pt), col = colour, lty = linetype) | |
element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour, lty = element$linetype) | |
polylineGrob( | |
x = xlist, y = ylist, id = idlist, ..., default.units = "npc", | |
gp = modifyList(element_gp, gp), | |
) | |
} | |
#------------------------------------------------------------------------------- | |
# For convenience: "L" (left + bottom) border | |
#------------------------------------------------------------------------------- | |
theme_L_border <- function(colour = "black", size = 1, linetype = 1) { | |
# use with e.g.: ggplot(...) + theme( panel.border=theme_L_border() ) + ... | |
structure( | |
list(colour = colour, size = size, linetype = linetype), | |
class = c("theme_L_border", "element_blank", "element") | |
) | |
} | |
element_grob.theme_L_border <- function( | |
element, x = 0, y = 0, width = 1, height = 1, | |
colour = NULL, size = NULL, linetype = NULL, | |
...) { | |
gp <- gpar(lwd = len0_null(size * .pt), col = colour, lty = linetype) | |
element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour, lty = element$linetype) | |
polylineGrob( | |
x = c(x+width, x, x), y = c(y,y,y+height), ..., default.units = "npc", | |
gp = modifyList(element_gp, gp), | |
) | |
} | |
#------------------------------------------------------------------------------- | |
# For convenience: bottom border only | |
#------------------------------------------------------------------------------- | |
theme_bottom_border <- function(colour = "black", size = 1, linetype = 1) { | |
# use with e.g.: ggplot(...) + theme( panel.border=theme_bottom_border() ) + ... | |
structure( | |
list(colour = colour, size = size, linetype = linetype), | |
class = c("theme_bottom_border", "element_blank", "element") | |
) | |
} | |
element_grob.theme_bottom_border <- function( | |
element, x = 0, y = 0, width = 1, height = 1, | |
colour = NULL, size = NULL, linetype = NULL, | |
...) { | |
gp <- gpar(lwd = len0_null(size * .pt), col = colour, lty = linetype) | |
element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour, lty = element$linetype) | |
polylineGrob( | |
x = c(x, x+width), y = c(y,y), ..., default.units = "npc", | |
gp = modifyList(element_gp, gp), | |
) | |
} | |
#------------------------------------------------------------------------------- | |
# For convenience: left border only | |
#------------------------------------------------------------------------------- | |
theme_left_border <- function(colour = "black", size = 1, linetype = 1) { | |
# use with e.g.: ggplot(...) + theme( panel.border=theme_left_border() ) + ... | |
structure( | |
list(colour = colour, size = size, linetype = linetype), | |
class = c("theme_left_border", "element_blank", "element") | |
) | |
} | |
element_grob.theme_left_border <- function( | |
element, x = 0, y = 0, width = 1, height = 1, | |
colour = NULL, size = NULL, linetype = NULL, | |
...) { | |
gp <- gpar(lwd = len0_null(size * .pt), col = colour, lty = linetype) | |
element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour, lty = element$linetype) | |
polylineGrob( | |
x = c(x, x), y = c(y, y+height), ..., default.units = "npc", | |
gp = modifyList(element_gp, gp), | |
) | |
} | |
#------------------------------------------------------------------------------- | |
# Border selection by number | |
#------------------------------------------------------------------------------- | |
theme_border_numerictype <- function(type, colour = "black", size = 1, linetype = 1) { | |
# use with e.g.: ggplot(...) + theme( panel.border=theme_border(type=9) ) + ... | |
structure( | |
list(type = type, colour = colour, size = size, linetype = linetype), | |
class = c("theme_border_numerictype", "element_blank", "element") | |
) | |
} | |
element_grob.theme_border_numerictype <- function( | |
element, x = 0, y = 0, width = 1, height = 1, | |
type = NULL, | |
colour = NULL, size = NULL, linetype = NULL, | |
...) { | |
if (is.null(type)) type = element$type | |
# numerical types from: library(gridExtra); example(borderGrob) | |
# 1=none, 2=bottom, 3=right, 4=top, 5=left, 6=B+R, 7=T+R, 8=T+L, 9=B+L, 10=T+B, 11=L+R, 12=T+B+R, 13=T+L+R, 14=T+B+L, 15=B+L+R, 16=T+B+L+R | |
xlist <- c() | |
ylist <- c() | |
idlist <- c() | |
if (type==2 || type==6 || type==9 || type==10 || type==12 || type==14 || type==15 || type==16) { # bottom | |
xlist <- append(xlist, c(x, x+width)) | |
ylist <- append(ylist, c(y, y)) | |
idlist <- append(idlist, c(1,1)) | |
} | |
if (type==4 || type==7 || type==8 || type==10 || type==12 || type==13 || type==14 || type==16) { # top | |
xlist <- append(xlist, c(x, x+width)) | |
ylist <- append(ylist, c(y+height, y+height)) | |
idlist <- append(idlist, c(2,2)) | |
} | |
if (type==5 || type==8 || type==9 || type==11 || type==13 || type==14 || type==15 || type==16) { # left | |
xlist <- append(xlist, c(x, x)) | |
ylist <- append(ylist, c(y, y+height)) | |
idlist <- append(idlist, c(3,3)) | |
} | |
if (type==3 || type==6 || type==7 || type==11 || type==12 || type==13 || type==15 || type==16) { # right | |
xlist <- append(xlist, c(x+width, x+width)) | |
ylist <- append(ylist, c(y, y+height)) | |
idlist <- append(idlist, c(4,4)) | |
} | |
if (type==1) { # blank; can't pass absence of coordinates, so pass a single point and use an invisible line | |
xlist <- c(x,x) | |
ylist <- c(y,y) | |
idlist <- c(5,5) | |
linetype <- "blank" | |
} | |
gp <- gpar(lwd = len0_null(size * .pt), col = colour, lty = linetype) | |
element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour, lty = element$linetype) | |
polylineGrob( | |
x = xlist, y = ylist, id = idlist, ..., default.units = "npc", | |
gp = modifyList(element_gp, gp), | |
) | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment