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")

There is an interesting article on nomography in my old 1957 Encyclopedia Britannica, including a simple one for the 3 sides of a right triangle.

ReplyDeleteWhat does yours here do?

Sorry for the slow response, Peter.

ReplyDeleteThis one computes the difference between a perpetuity and an annuity of term

nperiods, both at interest rateiper period.This is not a very useful function, it's just a simple function that I was playing with to see whether I could generate the nomogram.

This is part of an attempt to produce nomograms fitted to data. Pynomo (http://www.pynomo.org) draws nicer nomograms than this, but I needed something to quickly produce nomograms in R so I could see how my fitted equations work. It turned out to be relatively easy to get something basic up.