Sunday, January 10, 2010

Creating nomograms in R

This is actually a post-in-progress, but I am publishing it before it's ready so that people on the Nomography Discussion forum can come take a sneak preview. The post will probably be updated a couple of times.

Below is a three-scale nomogram I generated in R. Bitmap images (like this png) don't suit the text-at-an-angle of the i-scale, and the angled tick-marks, but it's good enough to give the idea - it looks better as a vector-image:(Click to obtain a slightly larger image)

Here's a simple function to draw nomogram scales. It's a few lines longer than when I wrote about it before (I added scale labels in). I don't expect anyone to care about the details of the code, but even without taking advantage of the special aspects of R, it's worth seeing that the entire code is quite compact, and fairly easy to generalize further.


curvaxis <- function(x,y,v,axlab=" ",ltick=TRUE,axlt1=TRUE,thwid=.02){
lines(x,y)

yscale <- diff(par("yaxp"))[1]
xscale <- diff(par("xaxp"))[1]
yxscale <- yscale/xscale

# compute ticks
n <- length(x)
tdif <- function(x,n=length(x)) c(x[2]-x[1],x[3:n]-x[1:(n-2)],x[n]-x[n-1])

s <- atan(-tdif(x)/tdif(y)*yxscale)
xd <- cos(s)*thwid*xscale # could do this without trig functions
yd <- sin(s)*thwid*yscale
xd <- ifelse(tdif(y)!=0,xd,0)
yd <- ifelse(tdif(y)!=0,yd,thwid*yscale) # are we scaling right? some ticks look off

dmul <- ifelse(ltick,-1,1)
xadj <- as.integer(ltick)
yadj <- 0.5

lines(rbind(x,x+dmul*xd,rep(NA,n)),rbind(y,y+dmul*yd,rep(NA,n))) # draw tick-marks
text(x+dmul*xd*1.5,y+dmul*yd*1.5,v,adj=c(xadj,yadj),cex=0.8,srt=180/pi*mean(s))# tick labels
sg <- sign(y[2]-y[1])
if(axlt1) { #cludgy - this part does the scale labels
text(x[1]-2*sin(s[1])*thwid*xscale,y[1]-2*sg*cos(s[1])*thwid*yscale,axlab,cex=1.33,srt=0,crt=0)
}
else {
text(x[n]+2*sin(s[n])*thwid*xscale,y[n]+2*sg*cos(s[n])*thwid*yscale,axlab,cex=1.33,srt=0,crt=0)
}
}


And this is the code that calls it:

#set up data
#variable 1
i <- .01*c(4:8,10,12,15,20)
li <- log(1+i)
yi <- -log(i)/(1+li)
xi <- li/(1+li)
yi <- yi-4*xi # skew the plot a bit

#variable 2
n <- 4:8
yn <- n-4
xn <- rep(1,length(n))

#variable 3
d <- c(1:6,8,10,15,20)
xd <- rep(0,length(d))
yd <- log(d)-4*xd

#scale the plot
xmin <- min(xd,xi,xn)
xmax <- max(xd,xi,xn)
ymin <- min(yd,yi,yn)
ymax <- max(yd,yi,yn)

xl <- xmin-0.02*(xmax-xmin)
xu <- xmax+0.02*(xmax-xmin)
yl <- ymin-0.02*(ymax-ymin)
yu <- ymax+0.02*(ymax-ymin)

#draw the nomogram
par(ann=FALSE, xaxt="n",yaxt="n",bty="n")
plot(NULL, xlim=c(xl,xu),ylim=c(yl,yu)) #draws a blank plot
curvaxis(xi,yi,i,axlab="i",ltick=FALSE,axlt1=FALSE)
curvaxis(xn,yn,n,axlab="n")
curvaxis(xd,yd,d,axlab="d")

Friday, January 1, 2010

2010 Mathematical Calendar

Ron Doerfler at Dead Reckonings has a 2010 "Graphical Computing" Calendar. It looks very nice.

See this post at Ron's blog