StATS: Code for drawing new likelihood ratio slide rule (July 12, 2007)

I have made some minor changes to my likelihood ratio slide. The original code was lost somewhere, so I wrote some new code and added documentation. I also changed the orientation of the slide rule so it can be held horizontally and shaded the regions that need to be cut out or away. This program runs in R. I've inserted images of the new slide rule on my tutorial page

The new version of the slide rule in PDF format has been placed on the web (SlideRule.pdf), and I am keepting the old version as well (SlideRuleOldVersion.pdf).

Here is the code.

#####################
# special functions #
#####################
hline <- function(x1,x2,y0) {segments(x1,y0,x2,y0)}
vline <- function(x0,y1,y2) {segments(x0,y1,x0,y2)}
rectangle <- function(x1,y1,x2,y2) {
 x0 <- c(x1,x1,x2,x2)
 y0 <- c(y1,y2,y2,y1)
 polygon(x=x0,y=y0,density=-1,border=NA,col="gray90")
}
triangle <- function(x1,y1,x2,y2,x3,y3) {
 x0 <- c(x1,x2,x3)
 y0 <- c(y1,y2,y3)
 polygon(x=x0,y=y0,density=-1,border=NA,col="gray90")
}

#####################################
# location of tick marks and labels #
#####################################

# where to draw probability tick marks
pr1 <- c(
 0.1,0.2,0.3,0.4,
 0.5,0.6,0.7,0.8,0.9,
 1,1.5,2,2.5,3,4,
 5,6,7,8,9,
 10,15,20,25,30,40,
 50,60,70,75,80,85,
 90,91,92,93,94,
 95,96,97,98,99)

# where to print probability labels
pr2 <- c(
 0.1,0.2,0.3,
 0.5,0.7,
 1,2,3,
 5,7,
 10,20,30,40,
 50,60,70,80,
 90,93,
 95,97,98,99)

# physical location of probability ticks and labels
pr3 <- 60+15*log(pr1/(100-pr1))/log(10)
pr4 <- 60+15*log(pr2/(100-pr2))/log(10)

n1 <- sort(c(1:9,1.5,2.5))
n2 <- c(1:3,5,7)

# where to draw likelihood ratio tick marks
pr5 <- c(n1/100,n1/10,n1,n1*10,100)

# where to print likelihood ratio labels
pr6 <- c(n2/100,n2/10,n2,n2*10,100)

# physical location of likelihood ratio ticks and labels
pr7 <- 50-15*log(pr5)/log(10)
pr8 <- 50-15*log(pr6)/log(10)

# odd and even probability labels
od2 <- paste(pr2[seq(1,length(pr2),by=2)],"%",sep="")
ev2 <- paste(pr2[seq(2,length(pr2),by=2)],"%",sep="")

# odd and even likelihood ratio labels
od4 <- pr4[seq(1,length(pr4),by=2)]
ev4 <- pr4[seq(2,length(pr2),by=2)]

# physical locations of odd/even labels
od6 <- pr6[seq(1,length(pr6),by=2)]
ev6 <- pr6[seq(2,length(pr6),by=2)]
od8 <- pr8[seq(1,length(pr8),by=2)]
ev8 <- pr8[seq(2,length(pr8),by=2)]

draw.frame <- function() {
 ################################
 # outline sleeve of slide rule #
 ################################
 hline( 5, 95, 0) # bottom edge
 hline( 0,100, 20) # fold line
 hline( 0,100, 50) # fold line
 hline( 5, 95, 70) # top edge
 vline( 0, 12, 28) # left edge
 vline( 0, 42, 58) # left edge
 vline(100, 12, 28) # right edge
 vline(100, 42, 58) # right edge

 ################
 # left notches #
 ################
 vline( 5, 0, 10)
 segments( 5, 10, 0, 12)

 segments( 0, 28, 5, 30)
 vline( 5, 30, 40)
 segments( 5, 40, 0, 42)

 vline( 5, 60, 70)
 segments( 0, 58, 5, 60)

 #################
 # right notches #
 #################
 vline( 95, 0, 10)
 segments( 95, 10,100, 12)

 segments(100, 28, 95, 30)
 vline( 95, 30, 40)
 segments( 95, 40,100, 42)

 vline( 95, 60, 70)
 segments(100, 58, 95, 60)

 ################################
 # outline insert of slide rule #
 ################################
 hline( 0,100, 71) # bottom edge
 hline( 0,100,100) # top edge
 vline( 0, 71,100) # left edge
 vline(100, 71,100) # right edge

 ####################################
 # cut-out for pre-test probability #
 ####################################
 h <- 29
 hline( 17, 83,h+0) # bottom edge
 hline( 17, 83,h+7) # top edge
 vline( 17,h+0,h+7) # left edge
 vline( 83,h+0,h+7) # right edge

 #####################################
 # cut-out for post-test probability #
 #####################################
 h <- 46
 v <- 50
 hline(v-3,v+3,h+0) # top edge
 hline(v-3,v+3,h-6) # bottom edge
 vline(v-3,h+0,h-6) # left edge
 vline(v+3,h+0,h-6) # right edge
 vline(v+0,h+0,h+1) # top tick
 vline(v+0,h-6,h-7) # bottom tick
}

draw.ticks <- function() {
 ####################
 # Likelihood ratio #
 ####################
 h <- 29
 segments(pr7,h+0,pr7,h-1) # all ticks
 segments(od8,h-2,od8,h-1) # extend odd ticks
 segments(ev8,h-4,ev8,h-1) # extend even ticks
 text(od8,h-3,od6) # label odd ticks
 text(ev8,h-5,ev6) # label even ticks

 ########################
 # Pre-test probability #
 ########################
 h <- 79
 segments(pr3,h-1,pr3,h+1) # all ticks
 segments(od4,h+2,od4,h+1) # extend odd ticks
 segments(ev4,h+4,ev4,h+1) # extend even ticks
 text(od4,h+3,od2) # label odd ticks
 text(ev4,h+5,ev2) # label even ticks

 #########################
 # Post-test probability #
 #########################
 h <- 97
 segments(pr3,h+1,pr3,h-1) # all ticks
 segments(od4,h-2,od4,h-1) # extend odd ticks
 segments(ev4,h-4,ev4,h-1) # extend even ticks
 text(od4,h-3,od2) # label odd ticks
 text(ev4,h-5,ev2) # label even ticks
}

draw.shade <- function() {
 xlo <- -999
 ylo <- -999
 xhi <- 999
 yhi <- 999

 #########################
 # shade extreme regions #
 #########################
 rectangle(xlo,ylo,xhi, 0) # bottom
 rectangle(xlo,100,xhi,yhi) # top
 rectangle(xlo,ylo, 0,yhi) # left
 rectangle(100,ylo,xhi,yhi) # right
 rectangle( 0, 70,100, 71) # between sleeve and insert

 ################
 # left notches #
 ################
 rectangle( 0, 0, 5, 10)
 triangle ( 0, 10, 5, 10, 0, 12)

 triangle ( 0, 30, 5, 30, 0, 28)
 rectangle( 0, 30, 5, 40)
 triangle ( 0, 40, 5, 40, 0, 42)

 triangle ( 0, 60, 5, 60, 0, 58)
 rectangle( 0, 60, 5, 70)

 #################
 # right notches #
 #################
 rectangle(100, 0, 95, 10)
 triangle (100, 10, 95, 10,100, 12)

 triangle (100, 40, 95, 40,100, 42)
 rectangle(100, 30, 95, 40)
 triangle (100, 30, 95, 30,100, 28)

 triangle (100, 60, 95, 60,100, 58)
 rectangle(100, 60, 95, 70)

 ########################
 # Pre-test probability #
 ########################
 h <- 29
 rectangle( 17,h+0, 83,h+7)

 #########################
 # Post-test probability #
 #########################
 h <- 46
 v <- 50
 rectangle(v-3,h-6,v+3,h+0)
}

draw.notes <- function() {
 m0 <- paste(
  "Line up the pre-test probability",
  "with the likelihood ratio, and read",
  "the post-test probability here."
  ,sep="\n")
 m1 <- paste(
  "(C) The Children's Mercy Hospital.",
  "For more information, please go to",
  "www.childrensmercy.org/sliderule.asp",
  sep="\n")
 text(45,43,m0,adj=1)
 text(55,43,m1,adj=0)
 text(15,33,"Pre-test\nprobability",adj=1)
 text(15,25,"Likelihood\nratio",adj=1)
}

pdf(file="sliderule.pdf",width=8,height=10)
 par(mar=rep(0.1,4),cex=0.75,adj=0.5)
 plot(c(0,100),c(0,100),axes=F,type="n",xlab=" ",ylab=" ")
 draw.notes()
 draw.shade()
 draw.frame()
 draw.ticks()
dev.off()

This page was written by Steve Simon while working at Children's Mercy Hospital. Although I do not hold the copyright for this material, I am reproducing it here as a service, as it is no longer available on the Children's Mercy Hospital website. Need more information? I have a page with general help resources. You can also browse for pages similar to this one at Category: Diagnostic testing.