#
# colourtables.R
#
# support for colour maps and other lookup tables
#
# $Revision: 1.13 $ $Date: 2010/06/14 12:07:20 $
#

colourmap <- function(col, ..., breaks=NULL, inputs=NULL) {
  stopifnot(is.character(col))
  f <- lut(col, ..., breaks=breaks, inputs=inputs)
  class(f) <- c("colourmap", class(f))
  f
}

lut <- function(outputs, ..., breaks=NULL, inputs=NULL) {
  n <- length(outputs)
  switch(is.null(breaks) + is.null(inputs) + 1,
         stop(paste("The arguments",
                    sQuote("breaks"), "and", sQuote("inputs"),
                    "are incompatible")),
         {},
         stop(paste("One of the arguments",
                    sQuote("breaks"), "or", sQuote("inputs"),
                    "should be given")))

  if(is.null(breaks)) {
    # discrete set of input values mapped to output values
    stopifnot(length(inputs) == length(outputs))
    stuff <- list(n=n, discrete=TRUE, inputs=inputs, outputs=outputs)
    f <- function(x, what="value") {
      m <- match(x, stuff$inputs)
      if(what == "index")
        return(m)
      cout <- stuff$outputs[m]
      return(cout)
    }
  } else {
    # interval of real line mapped to colours
    stopifnot(is.numeric(breaks) && length(breaks) >= 2)
    stopifnot(length(breaks) == length(outputs) + 1)
    if(!all(diff(breaks) > 0))
      stop("breaks must be increasing")
    stuff <- list(n=n, discrete=FALSE, breaks=breaks, outputs=outputs)
    f <- function(x, what="value") {
      stopifnot(is.numeric(x))
      x <- as.vector(x)
      z <- findInterval(x, stuff$breaks,
                        rightmost.closed=TRUE)
      if(what == "index")
        return(z)
      cout <- stuff$outputs[z]
      return(cout)
    }
  }
  attr(f, "stuff") <- stuff
  class(f) <- c("lut", class(f))
  f
}

print.lut <- function(x, ...) {
  stuff <- attr(x, "stuff")
  n <- stuff$n
  if(inherits(x, "colourmap")) {
    tablename <- "Colour map"
    outputname <- "colour"
  } else {
    tablename  <- "Lookup table"
    outputname <- "output"
  }
  if(stuff$discrete) {
    cat(paste(tablename, "for discrete set of input values\n"))
    out <- data.frame(input=stuff$inputs, output=stuff$outputs)
  } else {
    b <- stuff$breaks
    cat(paste(tablename, "for the range", prange(b[c(1,n+1)]), "\n"))
    leftend  <- rep("[", n)
    rightend <- c(rep(")", n-1), "]")
    inames <- paste(leftend, b[-(n+1)], ", ", b[-1], rightend, sep="")
    out <- data.frame(interval=inames, output=stuff$outputs)
  }
  colnames(out)[2] <- outputname
  print(out)
  invisible(NULL)
}

print.colourmap <- function(x, ...) {
  NextMethod("print")
}

summary.lut <- function(object, ...) {
  s <- attr(object, "stuff")
  if(inherits(object, "colourmap")) {
    s$tablename <- "Colour map"
    s$outputname <- "colour"
  } else {
    s$tablename  <- "Lookup table"
    s$outputname <- "output"
  }
  class(s) <- "summary.lut"
  return(s)
}

print.summary.lut <- function(x, ...) {
  n <- x$n
  if(x$discrete) {
    cat(paste(x$tablename, "for discrete set of input values\n"))
    out <- data.frame(input=x$inputs, output=x$outputs)
  } else {
    b <- x$breaks
    cat(paste(x$tablename, "for the range", prange(b[c(1,n+1)]), "\n"))
    leftend  <- rep("[", n)
    rightend <- c(rep(")", n-1), "]")
    inames <- paste(leftend, b[-(n+1)], ", ", b[-1], rightend, sep="")
    out <- data.frame(interval=inames, output=x$outputs)
  }
  colnames(out)[2] <- x$outputname
  print(out)  
}

plot.colourmap <- function(x, ..., main,
                           xlim=NULL, ylim=NULL, vertical=FALSE, axis=TRUE) {
  if(missing(main))
    main <- deparse(substitute(x))
  stuff <- attr(x, "stuff")
  col <- stuff$outputs
  n   <- stuff$n
  discrete <- stuff$discrete
  # determine pixel entries 'v' and colour map breakpoints 'bks'
  # to be passed to 'image.default'
  if(!discrete) {
    bks <- stuff$breaks
    rr <- range(bks)
    v <- seq(rr[1], rr[2], length=max(n+1, 1024))
  } else {
    v <- (1:n) - 0.5
    bks <- 0:n
    rr <- c(0,n)
  }
  # determine position of ribbon
  if(is.null(xlim) && is.null(ylim)) {
    u <- diff(rr)/10
    if(!vertical) {
      xlim <- rr
      ylim <- c(0,u)
    } else {
      xlim <- c(0,u)
      ylim <- rr
    }
  } else if(is.null(ylim)) {
    if(!vertical) 
      ylim <- c(0, diff(xlim)/10)
    else 
      ylim <- c(0, 10 * diff(xlim))
  } else if(is.null(xlim)) {
    if(!vertical) 
      xlim <- c(0, 10 * diff(ylim))
    else 
      xlim <- c(0, diff(ylim)/10)
  }
  # plot ribbon image
  linmap <- function(x, from, to) {
    to[1] + diff(to) * (x - from[1])/diff(from)
  }
  if(!vertical) {
    x <- linmap(v, rr, xlim)
    y <- ylim
    z <- matrix(v, ncol=1)
    do.call("image.default",
            resolve.defaults(list(x, y, z),
                             list(...),
                             list(main=main, xlim=xlim, ylim=ylim, asp=1.0,
                                  ylab="", xlab="", axes=FALSE,
                                  breaks=bks, col=col)))
    if(axis) {
      if(discrete) {
        la <- paste(stuff$inputs)
        at <- linmap(v, rr, xlim)
      } else {
        la <- pretty(rr)
        at <- linmap(la, rr, xlim)
      }
      axis(1, pos=ylim[1], at=at, labels=la)
    }
  } else {
    y <- linmap(v, rr, ylim)
    z <- matrix(v, nrow=1)
    x <- xlim
    do.call("image.default",
            resolve.defaults(list(x, y, z),
                             list(...),
                             list(main=main, ylim=ylim, xlim=xlim, asp=1.0,
                                  ylab="", xlab="", axes=FALSE,
                                  breaks=bks, col=col)))
    if(axis) {
      if(discrete) {
        la <- paste(stuff$inputs)
        at <- linmap(v, rr, ylim)
      } else {
        la <- pretty(rr)
        at <- linmap(la, rr, ylim)
      }
      axis(4, pos=xlim[2], at=at, labels=la)
    }
  }
  invisible(NULL)
}