R/gmMain.r

Defines functions gmLegend2 gmSelectColorByValue gmShowPalette gmArrowIndicator gmArrowIndicatorGrob gmRandomColor gmMakeVpBorders gmSplitTextBox drawDetails.gmSplitTextGrob gmSplitTextGrob gmSplitString gmTextBox gmSelectTextColorByLuminance gmGetHexLuminanceValues

#//////////////////////////////////////////////////////////////////////////////
#  	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
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()
markheckmann/OpenRepGrid documentation built on April 30, 2021, 2:33 a.m.