Nothing
# //////////////////////////////////////////////////////////////////////////////
# GRAPHICAL MODULES (gm) script collection
# graphical moduls is a collection of simple graphical templates
# that can be used to construct complex custom graphics.
# All functions from this collection start with the letters gm.
# Similar to the grid package when a grob is given as output
# the same functions name ends with Grob and has a corresponding
# cuntion that does not have grob at the end. e.g. gmFoo and gmFooGrob
#
# by Mark Heckmann 2009
# //////////////////////////////////////////////////////////////////////////////
# TODO: naming of function and corresponding grob function
# package dependencies:
# require(grid)
# require(colorspace)
# //////////////////////////////////////////////////////////////////////////////
###### FUNCTION DEFINITION ########
# extract luminance value from hex color value.
# done by conversion to rgb to lch space
# luminance is returned
# works vectorwise
# default.na is value returned if hex contains NAs
gmGetHexLuminanceValues <- function(hex, default.na = NA) {
sapply(hex, function(x) { # check if strings are hex, that is if the start with a "#"
if (substr(x, 1, 1) != "#" & !is.na(x)) {
stop("hex is not hexadecimal. getHexLuminanceValues() needs a hex color value!")
}
})
NAs <- is.na(hex) # hex2RGB needs hex values, NAs not accepted
hex[NAs] <- "#FFFFFF" # replace NAs by dummy hex value (white)
lch <- as(hex2RGB(hex), "polarLUV") # convert hex to rgb to lch , thanks to A. Zeileis r-help 20100129
lum <- as.vector(lch@coords[, "L"]) # return the luminance values only
lum[NAs] <- default.na
lum
}
## NOT RUN
# getHexLuminanceValues(c("#3B5715", "#910322"))
###### FUNCTION DEFINITION ########
# select a color from supplied vector corresponding to the
# luminance value of given hex colors and given breaks
# if hex contains NAs a default hex value can be passed and
# works vectorwise
# default.na is value returned if hex contains NAs
gmSelectTextColorByLuminance <- function(hex, breaks = c(-1, 50, 101), breakColors = c("white", "black"), default.na = NA) {
luminanceVec <- gmGetHexLuminanceValues(hex) # get luminance values from hex color
indices <- as.integer(cut(luminanceVec, breaks = breaks)) # cut by breaks and get indices
breakColors[indices] # return color by index
}
## NOT RUN
# selectTextColorByLuminance(c("#3B5715", "#910322"))
### SHOW EXAMPLE ###
## plot with random background and corresponding textcolor
# library(RColorBrewer)
# bgColors <- c(brewer.pal(8,"Purples"), brewer.pal(8,"YlOrRd"))
# textColors <- gmSelectTextColorByLuminance(bgColors)
# pushViewport(viewport(layout=grid.layout(4, 4, respect=TRUE)))
# for(i in 1:4){
# for(j in 1:4){
# grid.rect(gp=gpar(col="white", fill=bgColors[4*(i-1) + j]), vp=viewport(layout.pos.col=j, layout.pos.row=i))
# grid.text(paste("Zelle (", i, ",", j, ")", sep=""), gp=gpar(col=textColors[4*(i-1) + j]), vp=viewport(layout.pos.col=j, layout.pos.row=i))
# }
# }
# popViewport()
# //////////////////////////////////////////////////////////////////////////////
# //////////////////////////////////////////////////////////////////////////////
# like a gmTextBox
# like Murrels example that is rezisable but also viewport
# rotation enabled allowed
# //////////////////////////////////////////////////////////////////////////////
# gmTextBox fill a viewport with color, and text or two texts
#
# evtl mit gpar Objekten??
# wenn zwei Texte übergeben werden, so werden diese, je nachdem, ob horiz=TRUE oder FALSE ist neben
# oder untereinander dargestellt.
# TODO: ggf. das plotten von borderlines integrieren?
# Probleme mit den Rändern.
gmTextBox <- function(text = c("text 1", "text 2"), textCol = c("black", "black"),
bgCol = c(grey(.9), grey(.9)), vp = viewport(), textsize = c(.8, .8),
fontface = c("bold", "plain"), horiz = FALSE, vAdjust = c(.4, .65)) {
# vp=viewport()
# text=c("text 1", "text 2")
# textCol = c("black", "black")
# bgCol = "grey"
# horiz=FALSE
# borderCol <- c("black", "black", "black","black")
# twoTexts <- TRUE
###
if (length(text) == 2) {
twoTexts <- TRUE
} else {
twoTexts <- FALSE
} # two text bodies?
gpText_1 <- gpar(col = textCol[1], cex = textsize[1], fontface = fontface[1]) # make gpar objects
gpText_2 <- gpar(col = textCol[2], cex = textsize[2], fontface = fontface[2]) #
gpFill_1 <- gpar(fill = bgCol[1], col = bgCol[1]) # , col=NA) # no border
gpFill_2 <- gpar(fill = bgCol[2], col = bgCol[2]) # , col=NA) # no border
# three options: 1 text, 2 texts vertical, 2 texts horizontal
if (!twoTexts) { # just one text body
pushViewport(vp)
grid.rect(gp = gpFill_1)
grid.text(text[1], gp = gpText_1)
popViewport()
}
# TODO: dieser Ansatz ist noch nicht perfekt. Speziell, da ich verschiedene fontfaces für
# die obere und untere Zelle haben möchte müssen zwei textGrobs gebaut werden. Hier muss
# noch ein wenig Arbeit geleistet werden, um deren Größe zu messen unds ie nebeneinander
# sauber zu platzieren. Vlt. in der nächsten Version.
if (twoTexts) { # two text bodies
pushViewport(vp) # outer viewport
if (horiz) {
nRow <- 1
nCol <- 2
yOffset <- .5
} else {
nRow <- 2
nCol <- 1
yOffset <- vAdjust[1]
} # define layout with respect to orientation (horiz T/F)
pushViewport(viewport(layout = grid.layout(nRow, nCol))) # split viewport horizontally or vertically (horiz T/F)
posRow <- 1
posCol <- 1 # define row and column position of first viewport
pushViewport(viewport(layout.pos.row = posRow, layout.pos.col = posCol)) # push upper viewport
grid.rect(gp = gpFill_1)
grid.text(y = yOffset, text[1], gp = gpText_1, just = c("center", "center"))
popViewport()
if (horiz) {
posRow <- 1
posCol <- 2
yOffset <- .5
} else {
posRow <- 2
posCol <- 1
yOffset <- vAdjust[2]
} # define row and column position of second viewport
pushViewport(viewport(layout.pos.row = posRow, layout.pos.col = posCol)) # push lower viewport
grid.rect(gp = gpFill_2)
grid.text(y = yOffset, text[2], gp = gpText_2, just = c("center", "center"))
popViewport()
popViewport()
grid.rect(gp = gpar(col = "white", lwd = 2)) # border around whole vp
popViewport()
}
}
### NOT RUN ###
# gmTextBox()
# gmTextBox(c(12,"(14 %)"))
# gmTextBox(c(12))
## make a grid of gmTextBoxes
# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE)))
# for(i in 1:4){
# for(j in 1:4){
# gmTextBox(vp=viewport(layout.pos.row=i, layout.pos.col=j))
# }
# }
# popViewport()
## use data from data frame
# script <- matrix(sample(1:100, 16), ncol=4)
# subscript <- matrix(paste("(", sample(1:100, 16), "%)", sep=""), ncol=4)
# nCol <- ncol(script); nRow <- nrow(script)
# pushViewport(viewport(layout=grid.layout(nRow, nCol, respect=FALSE)))
# for(i in 1:nRow){
# for(j in 1:nCol){
# gmTextBox(c(script[i,j], subscript[i,j]), horiz=FALSE, vp=viewport(layout.pos.row=i, layout.pos.col=j))
# }
# }
# popViewport()
## plot with random background colors and corresponding textcolor overlay
# library(RColorBrewer)
# bgColors <- brewer.pal(8,"YlOrRd")
# script <- matrix(sample(1:100, 16), ncol=4)
# subscript <- matrix(paste("(", sample(1:100, 16), "%)", sep=""), ncol=4)
# bgColorsScript <- matrix(sample(bgColors, 16, rep=T), ncol=4)
# textColorsScript <- matrix(gmSelectTextColorByLuminance(bgColorsScript), ncol=4) # benutzt gmSelectTextColorByLuminance
# nCol <- ncol(script); nRow <- nrow(script)
# pushViewport(viewport(layout=grid.layout(nRow, nCol, respect=TRUE)))
# for(i in 1:nRow){
# for(j in 1:nCol){
# gmTextBox(text=c(script[i,j], subscript[i,j]), textCol=c(textColorsScript[i,j], textColorsScript[i,j]),
# bgCol=c(bgColorsScript[i,j], bgColorsScript[i,j]), vp=viewport(layout.pos.row=i, layout.pos.col=j))
# }
# }
# popViewport()
## uses gmRandomColor
# nRow <- 5; nCol <- 5
# script <- matrix(sample(1:100, nRow*nCol), ncol=nCol)
# subscript <- matrix(paste("(", sample(1:100, nRow*nCol), "%)", sep=""), ncol=nCol)
# pushViewport(viewport(layout=grid.layout(nRow, nCol, respect=TRUE)))
# for(i in 1:nRow){
# for(j in 1:nCol){
# randColor <- gmRandomColor()
# gmTextBox(text=c(script[i,j], subscript[i,j]), textCol=rep(gmSelectTextColorByLuminance(randColor),2),
# bgCol=rep(randColor, 2), vp=viewport(layout.pos.row=i, layout.pos.col=j))
# }
# }
# popViewport()
# //////////////////////////////////////////////////////////////////////////////
# gmSplitTextGrob
# text grob that automatically does line breaks in text, allows resizing
# and vertical orientation of
# TODO: - ggf. muss man sich überlegen, ob die momentane Form bei horiz=F
# geeignet ist. Denn man muss da umdenken. x muss nun .5 sein anstatt 0
# wenn der text nicht auch z.B an den linken Rand soll.
# - no vectorized form available yet
# adopted from Murrell(2008) R Graphics, p...
gmSplitString <- function(text, horiz = TRUE, splitWidth = unit(.98, "npc")) # function to split grobtext
{
# require(grid)
if (is.expression(text)) { # Expressions können nicht weiter verarbeitet werden
return(text)
# break
}
if (is.null(text)) text <- ""
if (length(text) == 1 & is.na(text)) text <- ""
if (is.character(text) & length(text) == 0) text <- ""
if (text == "") {
return(paste(text))
# break
}
strings <- strsplit(as.character(text), " ")[[1]]
if (length(strings) == 1) {
return(paste(strings))
# break
}
newstring <- strings[1]
linewidth <- stringWidth(newstring)
gapwidth <- stringWidth(" ")
if (!horiz) {
availwidth <- convertHeight(splitWidth, "inches", valueOnly = TRUE)
} else {
availwidth <- convertWidth(splitWidth, "inches", valueOnly = TRUE)
}
# print(availwidth);
for (i in 2:length(strings)) {
width <- stringWidth(strings[i])
if (convertWidth(linewidth + gapwidth + width,
"inches",
valueOnly = TRUE
) < availwidth) {
sep <- " "
linewidth <- linewidth + gapwidth + width
} else {
sep <- "\n"
linewidth <- width
}
newstring <- paste(newstring, strings[i], sep = sep)
}
newstring
}
# make text grob
gmSplitTextGrob <- function(text, x = unit(0.5, "npc"), y = unit(0.5, "npc"), just = c("center", "center"), gp = gpar(), horiz = TRUE, splitWidth = unit(.98, "npc"), ...) {
if (!is.unit(splitWidth)) splitWidth <- unit(splitWidth, "npc")
if (!horiz) rot <- 90 else rot <- 0
# print(horiz); print(rot);
grob(text = text, cl = "gmSplitTextGrob", x = x, y = y, just = just, rot = rot, horiz = horiz, gp = gp, splitWidth = splitWidth, ...)
}
# variation to explore
#' @export
#' @keywords internal
drawDetails.gmSplitTextGrob <- function(x, recording) # drawdetails method is called when resizing window
{
# str(x);
if (!x$horiz) {
grid.text(
label = gmSplitString(x$text, horiz = x$horiz, splitWidth = x$splitWidth),
rot = x$rot, just = x$just, x = x$x, y = x$y, gp = x$gp
)
} else {
grid.text(
label = gmSplitString(x$text, horiz = x$horiz, splitWidth = x$splitWidth),
rot = x$rot, just = x$just, x = x$x, y = x$y, gp = x$gp,
)
}
}
# printing wrapper for gmSplitTextGrob
gmSplitTextBox <- function(text, x = unit(0.5, "npc"), y = unit(0.5, "npc"), just = c("center", "center"), gp = gpar(), horiz = TRUE, splitWidth = unit(.98, "npc"), ...) {
tg <- gmSplitTextGrob(text, x = x, y = y, just = just, gp = gp, horiz = horiz, splitWidth = splitWidth, ...) # gmSplitTextGrob
grid.draw(tg) # print gmSplitTextGrob
}
### NOT RUN
# text <- "some random longer text that might be the label of an item"
# grid.draw(gmSplitTextGrob(text, horiz=T, just=c("center", "center")))
# grid.draw(gmSplitTextGrob(text, horiz=T, splitWidth=.9, x=0.05, y=.5, just=c("left", "center"), gp=gpar(col="darkgrey")))
# gmSplitTextBox(text, horiz=T, splitWidth=.9, x=0.05, y=.5, just=c("left", "center"), gp=gpar(col="darkgrey", lineheight=.8))
# gmSplitTextBox(text, h=F)
# splitText <- gmSplitTextGrob(text, horiz=F, class="gmSplitTextGrob", gp=gpar(fontsize=12, lineheight=.9))
# grid.draw(splitText)
## matrix of text with random orientation
# grid.newpage()
# text <- "some random longer text that might be the label of an item"
# textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4)
# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE)))
# for(i in 1:4){
# for(j in 1:4){
# grid.draw(gmSplitTextGrob(text, horiz=textOrientation[i,j],
# vp=viewport(layout.pos.row=i, layout.pos.col=j),
# gp=gpar(fontsize=12, lineheight=.9)))
# grid.rect(vp=viewport(layout.pos.row=i, layout.pos.col=j))
# }
# }
# popViewport()
## matrix of text with random orientation and random fore- and background color
# grid.newpage()
# text <- "some random longer text that might be the label of an item"
# textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4)
# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE)))
# for(i in 1:4){
# for(j in 1:4){
# randColor <- gmRandomColor()
# grid.rect(vp=viewport(layout.pos.row=i, layout.pos.col=j),
# gp=gpar(fill=randColor, col="lightgrey")))
# gmSplitTextBox(text, splitWidth=.9, horiz=textOrientation[i,j], vp=viewport(layout.pos.row=i, layout.pos.col=j),
# gp=gpar(fontsize=12, lineheight=.9, col=gmSelectTextColorByLuminance(randColor)))
# }
# }
# popViewport()
# //////////////////////////////////////////////////////////////////////////////
# gmMakeVpBorders
# uses the current vp and adds border lines at specified places
# is useful for the construction of tables etc. and an alternative
# to do this afterwards by whole lines.
# be careful with the visually adequate order of the sides as they are printed in the order given by side
# TODO: - recycle vector in lwd etc.? Evtl. kann ein NA stattdessen lieber
# dazu genutzt werden, dass die Linie nicht gezeichnet wird.
# - evtl. noch nicht ganz perfekt in bezug auf das clipping, da dies nicht
# als Funtkionsargument implementiert ist
gmMakeVpBorders <- function(side, col, lwd, ...) {
# col <- gmRandomColor(4)
# side <- 1:4
# lwd <- 50:54
for (i in side) {
if (i == 1 | i == "bottom") grid.lines(x = c(0, 1), y = c(0, 0), gp = gpar(lwd = lwd[side %in% i], col = col[side %in% i], lineend = "square"), ...)
if (i == 2 | i == "left") grid.lines(x = c(0, 0), y = c(0, 1), gp = gpar(lwd = lwd[side %in% i], col = col[side %in% i], lineend = "square"), ...)
if (i == 3 | i == "top") grid.lines(x = c(0, 1), y = c(1, 1), gp = gpar(lwd = lwd[side %in% i], col = col[side %in% i], lineend = "square"), ...)
if (i == 4 | i == "right") grid.lines(x = c(1, 1), y = c(0, 1), gp = gpar(lwd = lwd[side %in% i], col = col[side %in% i], lineend = "square"), ...)
}
}
# gmSplitTextBox("Some long text is written here", splitWidth=.9)
# gmMakeVpBorders(1:4, gmRandomColor(4), lwd=rep(30,4))
## matrix of text with random orientation and random fore- and background color
# grid.newpage()
# text <- "some random longer text that might be the label of an item"
# textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4)
# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE)))
# for(i in 2:3){
# for(j in 2:3){
# tmpVp <- viewport(layout.pos.row=i, layout.pos.col=j)
# grid.rect(gp=gpar(fill=gmRandomColor()), vp=tmpVp)
# gmSplitTextBox(text, splitWidth=.9, horiz=textOrientation[i,j], vp=tmpVp)
# gmMakeVpBorders(1:4, rep("grey", 4), lwd=rep(10,4), vp=tmpVp)
# }
# }
# popViewport()
## booktab like look
# grid.newpage()
# text <- "some random longer text that might be the label of an item"
# textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4)
# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE)))
# for(i in 1:4){
# for(j in 2:3){
# tmpVp <- viewport(layout.pos.row=i, layout.pos.col=j, clip=T) # im Moment noch clipping bei vp definition. Lieber direkt in Funktion
# grid.rect(gp=gpar(fill=gmRandomColor(v=.8), col=NA), vp=tmpVp)
# gmSplitTextBox(text, splitWidth=.9, horiz=textOrientation[i,j], vp=tmpVp)
# gmMakeVpBorders(1:4, rep("black", 4), lwd=c(4,NA, 4, NA), vp=tmpVp)
# }
# }
# popViewport()
# //////////////////////////////////////////////////////////////////////////////
# gmBulletPointsBox
# A function that prints a list of text elements as bullet points
# Bullets can be chosen any pch, numbers, letters or any other vector.
# //////////////////////////////////////////////////////////////////////////////
# gmProfileLines
# ask Hadley first if he already implicitly has it...
# //////////////////////////////////////////////////////////////////////////////
# gmRandomColor
# small convenience wrapper that returns a vector of random colors as hex
# unsing HSV scheme (hue, saturation, value)
# (requires RColorBrewer package).
# hue (1-360), saturation 0-1 and value 0-1 can be fixed or restricted to a range
# shuffle = shuffle the outoput vector, so patterns are destroyed
gmRandomColor <- function(n = 1, h = runif(n) * 360, s = runif(n), v = runif(n), shuffle = TRUE, plot = FALSE) {
# require(colorspace)
# hexColorVec <- hex(HSV(runif(n), runif(n), runif(n)))
hexColorVec <- hex(HSV(h, s, v))
if (shuffle) hexColorVec <- hexColorVec[sample(seq_along(hexColorVec), length(hexColorVec))]
if (plot) {
pal <- function(col, border = "light gray", ...) {
n <- length(col)
plot(0, 0,
type = "n", xlim = c(0, 1), ylim = c(0, 1),
axes = FALSE, xlab = "", ylab = "", ...
)
rect(0:(n - 1) / n, 0, 1:n / n, 1, col = col, border = border)
}
pal(hexColorVec)
}
return(hexColorVec)
}
### NOT RUN
# gmRandomColor()
# gmRandomColor(20, plot=T)
# gmRandomColor(30, h=100:200, v=3:10/10, p=T, shuffle=F)
# gmRandomColor(30, h=100:200, v=3:10/10, p=T)
# //////////////////////////////////////////////////////////////////////////////
# gmArrowIndicator
# an arrow of given size, angle, filling and background color which can be
# used to visuallize changes or rates.
# angle
# initAngle
# size in mm
# fill
# border
# background
## deprecated due to grob version below
# gmArrowIndicator <- function(angle=0, col="black", size=5, circle=FALSE, ...)
# {
# #gp <- modifyList(gpar(fill="black", col=NA, lwd=1, lineend ="square", # set default gpar and overwrite if provided
# # linejoin ="mitre", linemitre=1), gp)
#
# if(hasArg(vp)) vp <- list(...)$vp else vp <- viewport() # if vp is passed use it else create empty viewport
#
# pushViewport(vp)
# pushViewport(viewport(angle=angle))
# if(circle) grid.circle(x=0.5, y=0.5, r=unit(size+2,"mm"), gp=gpar(fill="lightgrey", col=NA))
#
# arrow <- arrow(angle = 35, length = unit(size, "mm"), type = "closed") # make arrow object to be passed to grid.lines
# grid.lines( x = unit(c(.5, .5), "npc") + unit(c(0,size), "mm"),
# y = unit(c(.5, .5), "npc"),
# arrow = arrow,
# gp=gpar(fill=col, lwd=1, col=NA, lineend ="square",
# linejoin ="mitre", linemitre=1))
# grid.lines( x = unit(c(.5, .5), "npc") + unit(c(-size/3,0), "mm"),
# y = unit(c(.5, .5), "npc"),
# gp= gpar(col=col, lwd=2*size, lineend ="square", linejoin ="mitre"))
# popViewport()
# popViewport()
# }
gmArrowIndicatorGrob <- function(angle = 0, col = "black", size = 5, circle = FALSE, initangle = 0, ...) {
# gp <- modifyList(gpar(fill="black", col=NA, lwd=1, lineend ="square", # set default gpar and overwrite if provided
# linejoin ="mitre", linemitre=1), gp)
vp <- viewport(angle = angle + initangle) # created rotated viewport for arrow direction
if (hasArg(vp)) vp <- vpStack(list(...)$vp, vp) # if vp is passed use it and stack the two viewports
if (circle) {
circleBackgroundGrob <- circleGrob(x = 0.5, y = 0.5, r = unit(size + 2, "mm"), gp = gpar(fill = "lightgrey", col = NA))
} else {
circleBackgroundGrob <- nullGrob()
}
arrow <- arrow(angle = 35, length = unit(size, "mm"), type = "closed") # make arrow description object to be passed to grid.lines
gTree(children = gList(
circleBackgroundGrob,
linesGrob(
x = unit(c(.5, .5), "npc") + unit(c(0, size), "mm"),
y = unit(c(.5, .5), "npc"),
arrow = arrow,
gp = gpar(
fill = col, lwd = 1, col = NA, lineend = "square",
linejoin = "mitre", linemitre = 1
),
vp = vp
),
linesGrob(
x = unit(c(.5, .5), "npc") + unit(c(-size / 3, 0), "mm"),
y = unit(c(.5, .5), "npc"),
gp = gpar(col = col, lwd = 2 * size, lineend = "square", linejoin = "mitre"),
vp = vp
)
))
}
gmArrowIndicator <- function(angle = 0, col = "black", size = 5, circle = FALSE, initangle = 0, ...) {
aiGrob <- gmArrowIndicatorGrob(
angle = angle, col = col, size = size,
circle = circle, initangle = initangle, ...
)
grid.draw(aiGrob)
}
## NOT RUN:
# gmArrowIndicator2(angle=10, vp=viewport(x=.9))
## array of arrows
# grid.newpage()
# angleMatrix <- matrix(sample(1:360, 16, rep=T), ncol=4)
# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE)))
# for(i in 1:4){
# for(j in 1:4){
# vpTmp <- viewport(layout.pos.row=i, layout.pos.col=j)
# grid.rect(vp=vpTmp)
# gmArrowIndicator(angleMatrix[i,j], vp=vpTmp)
# }
# }
# popViewport()
#
# ## array of arrows colored by angle
# grid.newpage()
# angleMatrix <- matrix(sample(1:360, 100, rep=T), ncol=10)
# pushViewport(viewport(layout=grid.layout(10, 10, respect=FALSE)))
# for(i in 1:10){
# for(j in 1:10){
# vpTmp <- viewport(layout.pos.row=i, layout.pos.col=j)
# grid.rect(vp=vpTmp)
# gmArrowIndicator(angleMatrix[i,j], col=gmRandomColor(), size=7, vp=vpTmp)
# }
# }
# popViewport()
#
# ## array of arrows colored by angle
# grid.newpage()
# angleMatrix <- matrix(1:100*3.6, ncol=10, byrow=T)
# pushViewport(viewport(layout=grid.layout(10, 10, respect=FALSE)))
# for(i in 1:10){
# for(j in 1:10){
# vpTmp <- viewport(layout.pos.row=i, layout.pos.col=j)
# grid.rect(vp=vpTmp)
# col <- gmSelectColorByValue(angleMatrix[i,j], seq(0, 360, by=10))
# gmArrowIndicator(angleMatrix[i,j], col=col, size=7, vp=vpTmp)
# }
# }
# popViewport()
#
# ## a frameGrob example
# rows <- 10; cols <- 10
# fg <- frameGrob(layout=grid.layout(rows,cols, widths=unit(rep(1.5,cols), "cm"), heights=unit(rep(1.5,rows), "cm")))
# for(i in 1:rows) for (j in 1:cols) fg <- placeGrob(fg, gmArrowIndicatorGrob(), i, j)
# grid.draw(fg)
#
# ## a frameGrob example
# rows <- 10; cols <- 10
# angleMatrix <- matrix(1:(rows*cols)*3.6, ncol=cols, byrow=T)
# gmSelectColorByValue(angleMatrix[i,j], seq(0, 360, by=10))
# fg <- frameGrob(layout=grid.layout(rows,cols, widths=unit(rep(1.5,cols), "cm"), heights=unit(rep(1.5,rows), "cm")))
# for(i in 1:rows) {
# for (j in 1:cols){
# col <- gmSelectColorByValue(angleMatrix[i,j], seq(0, 360, by=10))
# fg <- placeGrob(fg, gmArrowIndicatorGrob(angle=angleMatrix[i,j], col=col), i, j)
# }
# }
# grid.draw(fg)
# //////////////////////////////////////////////////////////////////////////////
# gmShowPalette
# convenient wrapper to look at a palett, taken from colorspace vignette
# gmShowPalette <- function(col, border = "light gray", ...)
# {
# n <- length(col)
# plot(0, 0, type="n", xlim = c(0, 1), ylim = c(0, 1),axes = FALSE, xlab = "", ylab = "", ...)
# rect(0:(n-1)/n, 0, 1:n/n, 1, col = col, border = border)
# }
# gmShowPalette(diverge_hcl(30, h = c(120, 20), c = 70, l = c(55, 98)))
# grid based version for better placement
gmShowPalette <- function(col, border = "light gray", ...) {
layout <- grid.layout(ncol = length(col))
fg <- frameGrob(layout = layout, ...)
for (i in seq_along(col)) {
fg <- placeGrob(fg, rectGrob(gp = gpar(fill = col[i], col = border)), col = i)
}
grid.draw(fg)
}
# gmShowPalette(diverge_hcl(30, h = c(120, 20), c = 70, l = c(55, 98)))
# //////////////////////////////////////////////////////////////////////////////
# gmSelectColorByValue
# TODO: vectorize, work on matrix, df etc.
# if value does not lie within any interval defined by breaks NA is returned
# if x contains NAs default.na is returned. The default is NA
# but a color can be specified in case needed.
gmSelectColorByValue <- function(x, breaks = seq(0, 100, by = 10),
colors = diverge_hcl(length(breaks) - 1, h = c(120, 20), c = 70, l = c(55, 98)),
default.na = NA) {
if (length(breaks) != (length(colors) + 1)) {
stop("breaks and colors have to be the same length!")
} # check if vectors have same length
is.na(x) <- is.na(x) # replacec NaNs by NA
x <- as.vector(x)
col <- cut(x, breaks = breaks, labels = colors)
col <- colors[as.integer(col)]
col[is.na(col)] <- default.na # replace NAs by default.na
col
}
# evtl. mal cut2 aus Hmisc anschauen
# gmSelectColorByValue(1:100)
# gmSelectColorByValue(c(NA, NA, 1:9))
# gmSelectColorByValue(c(NA, NA, 1:9), default.na="#EDEBEB")
# tmp <- gmSelectColorByValue(1:100, breaks= seq(0, 100, by=5))
# print(tmp)
# gmShowPalette(tmp)
# tmp <- gmSelectColorByValue(1:100, c(0,50,100), c("black", "white"))
# print(tmp)
# gmShowPalette(tmp)
# //////////////////////////////////////////////////////////////////////////////
# gmLegends
# there is a function for grid legends in vcd package, but it does
# not allow for multiple characters. The code is slightly modified
# allowing multiple characters in the first row
# WORKING PARTLY BUT STILL UNDER CONSTRUCTION!!!
# library(vcd)
# grid_legend(0.8, 0.9, c("aa","bb"), c("blue", "blue"), c("Port", "Starboard"), title = "SIDE")
# grid_legend(0.8, 0.9, c(1, 19), c("red", "blue"),
# c("Port", "Starboard"), title = "SIDE")
# x=.5
# y=.5
# pch=c(1,2)
# col="black"
# labels=c("Text 1", "Text2")
# frame = TRUE
# hgap = unit(0.5, "lines")
# vgap = unit(0.3, "lines")
# default_units = "lines"
# gp = gpar()
# draw = TRUE
# title = "Legend:"
# TODO: automatic deterination of wFirstRow by max stringwidth
gmLegend <- function(
x, y, pch, symbol = FALSE, col, labels, hgap = unit(
0.5,
"lines"
), wFirstCol = unit(2, "lines"), vgap = unit(0.3, "lines"), default_units = "lines",
gpRect = gpar(), gpText = gpar(), draw = TRUE, title = "Legend:") {
labels <- as.character(labels)
if (is.logical(title) && !title) {
title <- NULL
}
if (!is.null(title)) {
labels <- c(title, labels)
pch <- c(NA, pch)
col <- c(NA, col)
}
nkeys <- length(labels)
if (length(pch) != nkeys) {
stop("pch and labels not the same length")
}
if (!is.unit(hgap)) {
hgap <- unit(hgap, default_units)
}
if (length(hgap) != 1) {
stop("hgap must be single unit")
}
if (!is.unit(vgap)) {
vgap <- unit(vgap, default_units)
}
if (length(vgap) != 1) {
stop("vgap must be single unit")
}
legend.layout <- grid.layout(nkeys, 3,
widths = unit.c(wFirstCol, max(unit(
rep(1, nkeys),
"strwidth", as.list(labels)
)), hgap),
heights = unit.pmax(unit(1, "lines"), vgap + unit(
rep(1, nkeys),
"strheight", as.list(labels)
))
)
fg <- frameGrob(layout = legend.layout, gp = gpText)
# background col
fg <- placeGrob(fg, rectGrob(gp = gpRect))
for (i in 1:nkeys) {
tit <- !is.null(title) && i == 1
if (!tit) {
if (symbol) { # print text if symbol is FALSE (default)
fg <- placeGrob(fg, pointsGrob(0.5, 0.5,
pch = pch[i],
gp = gpar(col = col[i])
), col = 1, row = i)
} else {
fg <- placeGrob(fg, textGrob(
label = pch[i], x = 0.1, y = 0.5,
gp = gpar(col = col[i]), just = c("left", "center")
),
col = 1, row = i
)
}
}
fg <- placeGrob(fg, textGrob(labels[i], x = 0 + 0.3 *
tit, y = 0.5, just = c("left", "center")), col = 2 -
tit, row = i)
}
pushViewport(viewport(x, y,
height = unit(nkeys, "lines"),
width = grobWidth(fg)
))
# if (frame)
# fg <- placeGrob(fg, rectGrob(gp = gpar(fill = "transparent")))
if (draw) {
grid.draw(fg)
}
popViewport(1)
invisible(fg)
}
# labels=1:20
# legend with symbols
# gmLegend(x=0.25, y=0.5, symbol=TRUE, pch=seq_along(labels), col=rep("blue", length(labels)),
# labels=labels, gpText=gpar(cex=.7), title = "Test 1")
# without frame
# gmLegend(x=0.5, y=0.5, symbol=TRUE, pch=seq_along(labels), col=rep("brown", length(labels)),
# labels=labels, gpText=gpar(cex=.7, col=grey(.7)), gpRect=gpar(col=NA), title = "Test 2")
# legend with multi-character index column
# gmLegend(x=0.75, y=0.5, wFirstCol=unit(3, "lines"), hgap = unit(1, "lines"),
# pch=paste(LETTERS[1:20], labels, sep=""), labels=LETTERS[1:20], col=rep(rainbow(20), length(labels)),
# gpRect=gpar(col=1, fill=grey(.95), lty=3), gpText=gpar(col=grey(.5), cex=.7), title = NULL)
# //////////////////////////////////////////////////////////////////////////////
# gmLegends_2
# there is a function for grid legends in vcd package, but it does
# not allow for multiple characters. The code is slightly modified
# allowing multiple characters in the first row
# TODO: placeGrob nutzen sowie Spalten und Zeilenhöhe berechnen!
# background wird im moment einfach noch gezeichnet ohne args!
gmLegend2 <- function(colors, labels, ncol = NA, nrow = NA, byrow = TRUE,
symbolSize = unit(3, "mm"), symbolMargin = unit(2, "mm"),
bg = 1, na.bg = TRUE, force.height = FALSE, dynamic = TRUE) {
# args:
# byrow=T
# ncol=NA
# nrow=1
# colors <- rainbow(10)
## labels <- LETTERS[1:10]
# labels <- sapply(1:10, getRandString)
## args:
# symbolSize <- unit(3, "mm")
# symbolMargin <- unit(2, "mm")
# bg <- 1
# na.bg =TRUE # draw background in NA (unused) cells?
# input check
if (length(labels) != length(colors)) { # do colors match labels?
stop("Same length of colors and labels required!")
}
if (length(colors) == 1 & length(labels) > 1) { # one color many labels -> recycle color
colors <- rep(colors, length(labels))
}
if (sum(is.na(c(ncol, nrow))) != 1 |
!is.numeric(c(ncol, nrow))) {
stop("Please specify ncol OR nrow as positive integer.")
}
noCells <- length(labels)
# calcs: determine matrix size
if (is.na(nrow)) nrow <- noCells %/% ncol + (noCells %% ncol != 0) # needed no of rows
if (is.na(ncol)) ncol <- noCells %/% nrow + (noCells %% nrow != 0) # needed no of cols
# missing cells are given NAs
if (noCells != ncol * nrow) {
labels <- c(labels, rep(NA, ncol * nrow - noCells))
colors <- c(colors, rep(NA, ncol * nrow - noCells))
}
labelsMat <- matrix(labels, ncol = ncol, nrow = nrow, byrow = byrow)
colorsMat <- matrix(colors, ncol = ncol, nrow = nrow, byrow = byrow)
# labelsMat; colorsMat
# filling the layout
labelCell <- function(label) {
gTree(children = gList(
gmSplitTextGrob(label,
x = unit(2, "mm"),
y = unit(.5, "npc"),
just = c("left", "center"),
gp = gpar(lineheight = .7, cex = .8)
)
))
}
symbolCell <- function(fill, col = "black") {
gTree(children = gList(
rectGrob(
width = symbolSize, height = symbolSize,
gp = gpar(fill = fill, col = col)
)
))
}
backgroundCell <- function(gp = gpar()) {
gTree(children = gList(
rectGrob(width = 1, height = 1, gp = gp)
))
}
# make layout and frame
layout <- grid.layout(
nrow = nrow, ncol = ncol * 2,
widths = unit(rep(c(7, 1), ncol), rep(c("mm", "null"), ncol)),
heights = unit(rep(1, nrow), "lines")
)
fg <- frameGrob(layout = layout, name = "topFrame")
# make and add background object
bgCell <- rectGrob(gp = gpar(fill = grey(0.6), col = "white", lwd = 5))
fg <- packGrob(fg, bgCell, dynamic = dynamic, force.height = force.height)
# fill frame
for (i in 1:nrow) {
for (j in 1:(ncol)) {
bgGrob <- backgroundCell(gpar(fill = grey(.95), col = "white"))
draw.bg <- !(is.na(labelsMat[i, j]) & !na.bg)
if (bg == 1 & draw.bg) {
fg <- packGrob(fg, bgGrob, col = (2 * j - 1):(2 * j), row = i, dynamic = dynamic, force.height = force.height)
}
if (bg == 2 & draw.bg) {
fg <- packGrob(fg, bgGrob, col = (2 * j - 1), row = i, dynamic = dynamic, force.height = force.height)
fg <- packGrob(fg, bgGrob, col = (2 * j), row = i, dynamic = dynamic, force.height = force.height)
}
if (!is.na(colorsMat[i, j])) {
symbolGrob <- symbolCell(colorsMat[i, j], col = NA)
fg <- packGrob(fg, symbolGrob, col = 2 * j - 1, row = i, dynamic = dynamic, force.height = force.height)
}
if (!is.na(labelsMat[i, j])) {
cellGrob <- labelCell(labelsMat[i, j])
fg <- packGrob(fg, cellGrob, col = (2 * j), row = i, dynamic = dynamic, force.height = force.height)
}
}
}
return(fg)
}
# fg <- gmLegend2(rainbow(7), letters[1:7], ncol=3, bg=0)
# pushViewport(viewport(y=.3,height=unit(10, "mm"), width=.4))
# grid.draw(fg)
# popViewport()
# getRandString <- function(len=12) return(paste(sample(c(rep(0:9, each=5), LETTERS,letters, rep(c(" "), 10)),len,replace=TRUE),collapse=''))
# fg <- gmLegend2(rainbow(10), sapply(1:10, getRandString), ncol=3, byrow=F)
# pushViewport(viewport(y=.3,height=unit(10, "mm"), width=.4))#
# grid.draw(fg)
# popViewport()
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.