#================================================================
#
#               Programming 'Rapplets' --- Applets in R
#
# You may have seen and even used the identify function in R
# which allows you to put labels in plots interactively.
# Example:
    data(swiss)
    plot(swiss[,c("Education","Fertility")], pch=16)
    identify(swiss[,c("Education","Fertility")], lab=rownames(swiss))
    # Click on points to place a label; right-click -> 'Stop' to end.
# Another function: locator()
# Example: Draw polygonal lines by connecting clicked locations.
    par(mar=rep(.5,4))  # Draw blank canvas
    plot(x=0:1, y=0:1, type="n", xaxt="n", yaxt="n", xlab="", ylab="")
    locator(type="l")  # Right-click -> 'Stop' to end
    # A variation where we plot points at the click and show coordinates:
    repeat{ xy <- unlist(locator(n=1)) # locator() returns a list.
            rect(0,-par("cxy")[2]/2,par("cxy")[1]*12,par("cxy")[2],
                 col="white", border="white") # wipe out old text 
            text(x=0, y=0, adj=c(0,0),
                 lab=paste(round(xy,3),collapse=" | "))
            points(xy[1], xy[2], pch=16) # draw point at clicked location
            if(length(xy)==0) break }
# Finally, there is a menu() function:
    par(mar=c(3,3,1,1), mgp=c(1.8,.5,0))
    repeat{
      switch(menu(choices=c("Uniform","Normal","Exponential",
                            "Chi Square df=4","t df=3","Cauchy",
                            "Stop"), graphics=T, title="Pick one:"),
             hist(runif(10000), breaks=100, col="gray"),
             hist(rnorm(10000), breaks=100, col="gray"),
             hist(rexp(10000), breaks=100, col="gray"),
             hist(rchisq(10000,df=4), breaks=100, col="gray"),
             hist(rt(10000,df=3), breaks=100, col="gray"),
             hist(rcauchy(10000), breaks=100, col="gray"),
             break)
    }

# This is really crude, though: You cannot move the plot window
# while the menu is up, which is all the time.
# Thus, these tools are limited.  They do not provide the kind of
# flexible response to keyboard and mouse inputs we are used to in
# interactive software.
#
# All this changed a couple of years ago when a member of the R core
# team, Duncan Murdoch at Western Ontario U, wrote an R function
# which he describes as a 'thin wrapper' around the mouse events
# generated by the Windows operating system.
# [Big caveat: This is not available on Macs!]
# Duncan Murdoch's function:  'getGraphicsEvent()'  [part of R on Windows]
# It accepts arguments that are functions that get executed whenever 
#   1) the mouse is clicked,
#   2) the mouse moves, or
#   3) the keyboard is hit.
# Think of the function as an infinite loop that keeps waiting for
# mouse/kbd events and executing the functions accordingly.
#
# Best to start with some examples:
# Step 0 is to define a function that translates screen coordinates
# to user coordinates:
    gGE.trans <- function(x,y) {  # translate input coords to user coords
      plt <- par()$plt;  usr <- par()$usr
      xx = (x-plt[1])/(plt[2]-plt[1])*(usr[2]-usr[1]) + usr[1]
      yy = (y-plt[3])/(plt[4]-plt[3])*(usr[4]-usr[3]) + usr[3]
      c(xx,yy)  }
# For a toy example, a drawing program, set up a blank canvas:
    par(mar=rep(.5,4))
    plot(x=0:1, y=0:1, type='n', xaxt="n", yaxt="n", xlab="", ylab="")
# Then define two functions, one to draw dots, the other to quit:
    dot <- function(buttons,x,y) {
      points(rbind(gGE.trans(x,y)), pch=16); NULL } # Return NULL to go on
    kbd <- function(key) { if(key=="q") 0 else NULL }
# Convention: If any of such mouse/kbd functions returns non-NULL,
#             getGraphicsEvent() returns, breaking out of its loop.
# ==> Returning NULL from the above functions keeps the loop going.
# Here is how to draw individual points on mouse clicks:
    getGraphicsEvent("Hit 'q' to quit",
                     onMouseDown = dot,
                     onKeybd = kbd )
# Here is how to draw points continuously as the mouse moves:
    getGraphicsEvent("Hit 'q' to quit",
                     onMouseMove = dot,
                     onKeybd = kbd )
# The following almost amounts to a drawing program: draw on drag
    dot <- function(buttons,x,y) {
      if(length(buttons)>0) points(rbind(gGE.trans(x,y)), pch=16); NULL }
    kbd <- function(key) {
      if(key=="c") rect(-1,-1,2,2,col="white")  # Clear the canvas
      if(key=="q") 0 else NULL }
    getGraphicsEvent("Hit 'q' to quit",
                     onMouseMove = dot,
                     onKeybd = kbd )

#================================================================

# Real application: Animation of Regression to the Mean
#   Think of X as fathers' heights, Y as sons' heights.
#   Galton's observation was that the correlation was about 0.7,
#   and the line connecting local means had a tilt of about 0.7 also.
#   He concluded that fathers' heights 'explain'
#   about half the variation of sons' heights:  0.7^2 ~ 0.5

r2m <- function() {
  if(!exists("r2m.d")) { r2m.d <<- r2m.fill() }
  titl <- paste(c("Regression to the Mean: ", 
                rbind(c("r=", ",  R2=", ",  sqrt(1-R2)="),
                      format(round(c(99.99, cos(r2m.d$a), cos(r2m.d$a)^2,
                                     sqrt(1-cos(r2m.d$a)^2)), 2))[-1])
                ), collapse="", sep="")
  r2m.kbd("")
  getGraphicsEvent("Regression to the Mean: Hit upper case 'H' for help",
                   onKeybd=r2m.kbd)
}
r2m.fill <- function(N=5000, mx=3, big=10, cex=.3, a=pi/2, 
                     bin=1/3, ladder=c(-big,seq(-2-bin,+2+bin,by=bin),+big)) {
  x <- c(scale(rnorm(N)))
  x.cut <- cut(x, ladder)
  z <- c(scale(rnorm(N)))
  z <- c(scale(z-sum(x*z)/sum(x^2)*x))
  y <- sin(a)*z + cos(a)*x
  list(N=N, n=N, a=a, add.mns=F, add.line=F, add.pts=T,
       add.diag=F, add.ell=F, add.hor=F, 
       x=x, z=z, x.cut=x.cut, gray.bins=20, gray.pts=60,
       mx=mx, big=big, ladder=ladder, cex=cex)
  }
r2m.kbd <- function(key) {
  if(key=="H") { menu(choices=c(
                        "Depress 'a': Add to tilt",
                        "Depress 'f': Flatten tilt",
                        "Depress 'i':  Zoom in",
                        "Depress 'o': Zoom out",
                        "Depress '-': Darker points",
                        "Depress '=': Brighter points",
                        "Depress '+': More points",
                        "Depress '_': Fewer points",
                        "Toggle 'l':  LS line",
                        "Toggle 'm': Means",
                        "Toggle 'd': Diagonal 45 deg",
                        "Toggle 'e': Ellipse",
                        "Toggle 'h': Horizontal line",
                        "Toggle 'p': Points",
                        "Hit 'n': New points",
                        "Hit 'r': Reset" ,
                        "Hit 'H' (caps): Help (this here)",
                        "Hit 'q': Quit"),
       graphics = T, title = "Key Strokes:") }
  if(key=="a") { r2m.d$a <<- max(r2m.d$a-pi/180, 0) }
  if(key=="f") { r2m.d$a <<- min(r2m.d$a+pi/180, +pi/2) }
  if(key=="d") { r2m.d$add.diag <<- !r2m.d$add.diag }
  if(key=="e") { r2m.d$add.ell <<- !r2m.d$add.ell }
  if(key=="l") { r2m.d$add.line <<- !r2m.d$add.line }
  if(key=="h") { r2m.d$add.hor <<- !r2m.d$add.hor }
  if(key=="m") { r2m.d$add.mns <<- !r2m.d$add.mns }
  if(key=="p") { r2m.d$add.pts <<- !r2m.d$add.pts }
  if(key=="=") { r2m.d$gray.pts <<- min(r2m.d$gray.pts+2,99)
                 r2m.d$gray.bins <<- min(r2m.d$gray.bins+2,99) }
  if(key=="-") { r2m.d$gray.pts <<- max(r2m.d$gray.pts-2,10)
                 r2m.d$gray.bins <<- max(r2m.d$gray.bins-2,10) }
  if(key=="+") { r2m.d$n <<- min(r2m.d$n+20, r2m.d$N) }
  if(key=="_") { r2m.d$n <<- max(r2m.d$n-20, 100) }
  if(key=="i") { r2m.d$mx <<- r2m.d$mx/1.02 }
  if(key=="o") { r2m.d$mx <<- r2m.d$mx*1.02 }
  if(key=="r") { r2m.d <<- r2m.fill() }
  if(key=="n") {
    z <- c(scale(rnorm(r2m.d$N)))
    r2m.d$z <<- c(scale(z-sum(r2m.d$x*z)/sum(r2m.d$x^2)*r2m.d$x))
  }
  y <- sin(r2m.d$a)*r2m.d$z + cos(r2m.d$a)*r2m.d$x
  titl <- paste(c("Regression to the Mean: ", 
                  rbind(c("r=", ",  R2=", ",  sqrt(1-R2)="),
                        format(round(c(99.99, cos(r2m.d$a), cos(r2m.d$a)^2,
                                       sqrt(1-cos(r2m.d$a)^2)), 2))[-1]),
                  ",  n=",r2m.d$n
                ), collapse="", sep="")
  par(mar=c(3.5, 3.5, 3.5, 1.5), mgp=c(1.8, 0.5, 0))
  plot(x=0:1, y=0:1, type="n",
       xlim=c(-r2m.d$mx,r2m.d$mx), ylim=c(-r2m.d$mx,r2m.d$mx), xlab="x", ylab="y",
       main=titl , cex.main=.8)
  usr <- par()$usr;  rect(usr[1], usr[3], usr[2], usr[4], col="black")
  if(r2m.d$add.pts) {
    points(x=r2m.d$x[1:r2m.d$n], y=y[1:r2m.d$n],
           pch=16, cex=r2m.d$cex, col=paste("gray",r2m.d$gray.pts,sep=""))
  }
  if(r2m.d$add.hor) {
    lines(c(-r2m.d$big,r2m.d$big), c(0,0), lwd=2, col="orange")
  }
  if(r2m.d$add.diag) {
    lines(c(-r2m.d$big,r2m.d$big), c(-r2m.d$big,r2m.d$big), lwd=2, col="turquoise")
  }
  if(r2m.d$add.ell) {
    angs <- seq(0,2*pi,by=pi/90)
    x.ell <- 2.145966*cos(angs);  z.ell <- 2.145966*sin(angs)
    y.ell <- sin(r2m.d$a)*z.ell + cos(r2m.d$a)*x.ell
    lines(x.ell, y.ell, lwd=2, col="turquoise")
  }
  if(r2m.d$add.line) {
    lines(c(-r2m.d$big,r2m.d$big), cos(r2m.d$a)*c(-r2m.d$big,r2m.d$big), lwd=2, col="green")
  }
  if(r2m.d$add.mns) {
    ladder <- r2m.d$ladder[-c(1,length(r2m.d$ladder))]
    mns <- tapply(y[1:r2m.d$n], r2m.d$x.cut[1:r2m.d$n], mean)[-c(1,length(r2m.d$ladder)-1)]
    big <- r2m.d$big
    lines(x=c(rbind(c(ladder[-length(ladder)]), ladder[-1], NA)),
          y=c(rbind(mns, mns, NA)), lwd=4,  col="red")
    lines(x=c(rbind(ladder,ladder,NA)), y=rep(c(-big,big,NA),length(ladder)),
          col=paste("gray",r2m.d$gray.bins,sep=""))
  }
  if(key=="q") "Quit" else NULL
}

# Run the program:
r2m()

#================================================================