#
# --------- Proper Scoring Animation ---------
# 
# Execute the following in an R interpreter:
#        source("proper-scoring-rapplet.R")
#        ps$start()
# Then mouse-drag in the R plot window and hit 'h' for help.
#
ps <- NULL
ps$start <- function() {
  if(is.null(ps$R)) ps$kbd("l")
  ps$eta <<- .5
  ps$plot()
  getGraphicsEvent(onMouseDown=ps$md,
                   onMouseMove=ps$md,
                   onKeybd=ps$kbd,
                   prompt="Proper Scoring Animation [Hit 'h' for Help]")
}
ps$plot <- function() {
  eta <- ps$eta
  eta <- min(1,max(0,eta))
  par(mgp=c(2,0.5,0), mar=c(3.5,3.5,1,1))
  p <- seq(.00000001,.99999999, length=1000)
  entropy <- ps$R(p,p)
  plot(c(0,1), c(0,2.3*max(entropy)), type="n", cex.lab=1.5,
       xlab="p", ylab=expression(paste("L(",eta,"|p)")))
  text(x=mean(par()$usr[1:2]), y=par()$usr[4], lab=ps$lab, adj=c(.5,1.1), cex=1.2)
  lines(p, ps$R(0,p),  col="gray")
  lines(p, ps$R(1,p),  col="gray")
  lines(p, entropy, col="blue")
  lines(p, ps$R(eta,p),  lty=1, lwd=2, col="red")
  lines(c(eta,eta), c(-1, ps$R(eta,eta)))
  text(x=eta, y=ps$R(eta,eta), lab=bquote(paste(eta,"=",.(round(eta,2)),sep="")),
       cex=1.5, adj=c(.5,-.2))
} # End of: ps$plot
ps$kbd <- function(key) {
  if(key=="b") { ps$R <<- function(eta,p) eta*sqrt((1-p)/p) + (1-eta)*sqrt(p/(1-p));
                 ps$lab <<- "Boosting Loss, a=b= -1/2" }
  if(key=="l") { ps$R <<- function(eta,p) - eta*log(p) - (1-eta)*log(1-p);
                 ps$lab <<- "Log-Loss, a=b=0" }
  if(key=="s") { ps$R <<- function(eta,p) eta*(1-p)^2 + (1-eta)*p^2;
                 ps$lab <<- "Squared Error Loss, a=b=1" }
  if(key=="1") { ps$R <<- function(eta,p) eta*(1-p) + (1-eta)*(-p-log(1-p));
                 ps$lab <<- "Tailored, a=1, b=0" }
  if(key %in% 2:9) { ps$R <<- function(eta,p) { a <- as.numeric(key)
                                                eta*( p^(a+1)/(a+1) - p^a/a - 1/(a+1) + 1/a) +
                                                (1-eta)*( p^(a+1)/(a+1) ) }
                                                ps$lab <<- paste("Tailored Loss, a=",key," b=1",sep="") }
  if(key=="c") { ps$R <<- function(eta,p) { cost <- 0.55; eta*(1-cost)*(p<cost) + (1-eta)*cost*(p>=cost) };
                 ps$lab <<- "Classification Loss, Cost/Quantile=0.55" }
  if(key=="h") { menu(choices=c("-----------------------",
                                "Drag Left Mouse: choose eta in p -> L(eta|p)",
                                "Hit 'l': Log-Loss",
                                "Hit 'b': Boosting Loss",
                                "Hit 's': Squared Error Loss",
                                "Hit 'c': Classification Loss",
                                "Hit '1'...'9': Tailored Loss, a=key, b=1",
                                "-----------------------",
                                "Red curve: Risk        L(eta|p)",
                                "Increasing gray curve: L(0|p)",
                                "Decreasing gray curve: L(1|p)",
                                "Blue curve: Entropy/Bayes risk"
                        ),
                      graphics=T, title="Proper Scoring Animation: Help") }
  ps$plot()
  if(key=="q") { "Quit" } else { NULL }  # Return NULL to continue
} # End of: ps$kbd
ps$md <- function(button, x, y) {  # mousedown function for getGraphicsEvent
  if(length(button)>0) { 
    plt <- par()$plt;    usr <- par()$usr
    mouse.xy <- c((x-plt[1])/(plt[2]-plt[1])*(usr[2]-usr[1]) + usr[1],
                  (y-plt[3])/(plt[4]-plt[3])*(usr[4]-usr[3]) + usr[3] )
    ps$eta <<- mouse.xy[1]
    ps$plot()
  }
  NULL
} # End of: ps$md

# Execute:
ps$start()