Skip to content →

Multinomial nomogram

R-script to generate a generic nomogram for multinomial logistic (prediction) models.

########################################################################################################
# Plot and save generic nomogram for multinomial logistic regression models
#
# h           : height of the plot in centimeter (default: 15cm)
# d           : width of the plot in centimeter (default: 15cm)
# lp.range    : range of linear predictor values (L axis, default -3 to 2)
# sumlp.range : range of sum of linear predictor values (S axis, default 0 to 7)
# lp.tickby   : distance between large tickmarks for the L axis (default .5)
# sumlp.tickby: distance between large tickmarks for the S axis (default .5)
# o.tickby    : distance between large tickmarks for the O axis (default .1)
# small.ticks : distance between small tickmarks for L, S and O (default .1,.1,.025)
# cex.axis    : letter size for axes (default .5)
# name.pdf    : name for pdf file to save plot; if NULL, plot will not be saved (default: NULL)
########################################################################################################
# Author  : Maarten van Smeden
# Contact : M.vanSmeden@umcutrecht.nl
#
# Version : 1 December 2016
# Disclaimer: This is a free software program that comes with no warranty. 
# Recommendations for improvement and bug-reports are welcome.
########################################################################################################

plot.lrnomogram <- function(h=15,d=15,lp.range=c(-3,2),sumlp.range=c(7,0), 
                            lp.tickby=.5,sumlp.tickby=.5,o.tickby=.1,
                            small.ticks=c(.1,.1,.025),cex.axis=.5,
                            name.pdf=NULL,...){
  
  c.star <- -c(log(1+sumlp.range[1]),log(1+sumlp.range[2]))

  m1 <- h/(lp.range[2]-lp.range[1])
  m3 <- h/(c.star[2]-c.star[1])
    m2 <- m1*m3/(m1+m3)
      d.lo <- d-(d/(m1/m3+1))
  
  a.label <- seq(from=lp.range[1],to=lp.range[2],by=lp.tickby)
    a.rescale <- m1*(a.label-a.label[1])
  a.s.tick <- seq(from=lp.range[1],to=lp.range[2],by=small.ticks[1])
    a.s.tick.rescale <- m1*(a.s.tick-a.label[1])

  c.label <- seq(from=sumlp.range[1],to=sumlp.range[2],by=-lp.tickby)
    c.rescale <- m3*(-log(1+c.label)+log(1+c.label[1]))  
  c.s.tick <- seq(from=sumlp.range[1],to=sumlp.range[2],by=-small.ticks[2])
    c.s.tick.rescale <- m3*(-log(1+c.s.tick)+log(1+c.s.tick[1]))  
    
  b.label <- seq(from=0,to=1,by=o.tickby)
  b.s.tick <- seq(from=0,to=1,by=small.ticks[3])
  b.zero <- exp(lp.range[1])/(1+sumlp.range[1])
    b.rescale <- m2*(log(b.label)-log(b.zero))
    b.s.tick.rescale <- m2*(log(b.s.tick)-log(b.zero))
  
  if(!is.null(name.pdf)) pdf(name.pdf,paper="a4",height=(h/2.54)+1)
    par(pin=c(d/2.54,h/2.54),xaxs="i",yaxs="i",xpd=NA)
    plot(NA,xlim=c(0,d),ylim=c(0,h),ylab="",xlab="",main="",axes=F)
    
    axis(2,at=a.rescale,labels=a.label,par(las=1,tck=-.015),cex.axis=cex.axis)
    axis(2,at=a.s.tick.rescale,labels=NA,par(las=1,tck=-.010))
    
    axis(4,at=c.rescale,labels=c.label,par(las=1,tck=-.015),cex.axis=cex.axis)
    axis(4,at=c.s.tick.rescale,labels=NA,par(las=1,tck=-.010))
   
    axis(2, pos=d.lo, at=b.rescale[-1],labels=b.label[-1],par(las=1,tck=-.015),cex.axis=cex.axis)
    axis(2, pos=d.lo, at=b.s.tick.rescale[-1],labels=NA,par(las=1,tck=-.010))
    axis(2, pos=d.lo ,at=b.s.tick.rescale[2],labels=b.s.tick[2],cex.axis=cex.axis)
    
    text(x=c(0,d.lo,d), y=c(h+.5,h+.5,h+.5),labels=c("L","O","S"),cex=.75)
    
  if(!is.null(name.pdf)) dev.off()
}

plot.lrnomogram()