########################################################################
#
# John W. Emerson
# Department of Statistics
# Yale University
#
# Walton Green
# Department of Geology and Geophysics
# Yale University
#
# John Hartigan
# Department of Statistics
# Yale University
#
########################################################################
########################################################################
## Copyright (C) 2006 John W. Emerson
##
## This document is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2, or (at your option)
## any later version.
##
## This program is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
## General Public License for more details.
##
## A copy of the GNU General Public License is available via WWW at
## http://www.gnu.org/copyleft/gpl.html.  You can also obtain it by
## writing to the Free Software Foundation, Inc., 675 Mass Ave,
## Cambridge, MA 02139, USA.
##
## Bug reports to john.emerson@yale.edu
########################################################################
########################################################################

barcode.panel <- function(x, horizontal=TRUE, labelloc=TRUE, axisloc=TRUE,
                          labelouter=FALSE, nint=0, fontsize=9,
                          ptsize=unit(0.25, "char"), ptpch=1, bcspace=NULL,
                          xlab="", xlaboffset=unit(2.5, "lines"),
                          use.points=FALSE) {

  if (!is.list(x)) { stop("x must be a list") }
  K <- length(x)
  for (i in 1:K) x[[i]] <- x[[i]][!is.na(x[[i]])]

  # Figure out some global things we'll need for spacing:  
  maxct <- 0
  maxes <- rep(0, K)
  minx <- min(unlist(x)) - 0.02*(max(unlist(x))-min(unlist(x)))
  maxx <- max(unlist(x)) + 0.02*(max(unlist(x))-min(unlist(x)))
  xleftoffset <- unit(1, "strwidth", names(x)[1])
  for (i in 1:K) {
    y <- x[[i]]
    if (nint>0) z <- hist(y, breaks=pretty(unlist(x), n=nint), plot=FALSE)$counts
    else z <- table(y)
    maxct <- max(maxct, max(z))
    maxes[i] <- max(z)
    xleftoffset <- max(xleftoffset, unit(1, "strwidth", names(x)[i]))
  }
  xleftoffset <- 1.05*xleftoffset
  if (is.null(labelloc) || !labelloc) {
    xrightoffset <- xleftoffset
    xleftoffset <- unit(0, "npc")
    xtextloc <- unit(1, "npc") - xrightoffset
    xtextalign <- "left"
  } else {
    xrightoffset <- unit(0, "npc")
    xtextloc <- xleftoffset
    xtextalign <- "right"
  }
  if (labelouter) {
    xleftoffset <- unit(0, "npc")
    xrightoffset <- unit(0, "npc")
    if (is.null(labelloc) || !labelloc) xtextloc <- unit(1.02, "npc")
    else xtextloc <- unit(-0.02, "npc")
  }
  if (is.null(bcspace)) bcspace <- max(0.2, 1.5 / (maxct + 1))


  # Now do each of the barcodes:
  for (i in 1:K) {

    y <- x[[i]]

    # Handle the factor labels:
    if (!is.null(labelloc))
      grid.text(names(x)[i], x=xtextloc, y=unit((i-1)/K, "npc")+0.5*unit(1/K, "npc"),
                just=xtextalign, gp=gpar(fontsize=fontsize))

    if (nint>0) {
      zhist <- hist(y, breaks=pretty(unlist(x), n=nint), plot=FALSE)
      z <- zhist$counts
      mids <- zhist$mids
    } else {
      z <- table(y)
      mids <- as.numeric(names(z))
    }

    # The barcode part of things:
    vp.barcode <- viewport(x=xleftoffset,
                           y=unit((i-1)/K, "npc"),
                           w=unit(1, "npc")-xleftoffset-xrightoffset,
                           h=unit(1/K, "npc")*bcspace,
                           xscale=c(minx, maxx), yscale=c(0,1),
                           just=c("left", "bottom"),
                           name="barcode", clip="off")
    pushViewport(vp.barcode)
    grid.segments(unit(mids[z>0], "native"), 0.05, unit(mids[z>0], "native"), 0.95)

    if (!is.null(axisloc) && (i==1 & axisloc)) {
      grid.xaxis(main=axisloc, gp=gpar(fontsize=fontsize))
      grid.text(xlab, x=unit(0.5, "npc"), y=unit(0, "npc") - xlaboffset)
    }

    popViewport(1)

    # The histogram part of things:
    vp.hist <- viewport(x=xleftoffset,
                        y=unit((i-1)/K, "npc")+unit(1/K, "npc")*bcspace,
                        w=unit(1, "npc")-xrightoffset-xleftoffset,
                        h=unit(1/K, "npc")-unit(1/K, "npc")*bcspace,
                        xscale=c(minx, maxx), yscale=c(0,1),
                        just=c("left", "bottom"),
                        name="hist", clip="off")
    pushViewport(vp.hist)
    vp.buffer <- viewport(x=0, y=0.05, w=1, h=0.9, just=c("left", "bottom"),
                          xscale=c(minx, maxx), yscale=c(0,1))
    pushViewport(vp.buffer)
    if (!is.null(axisloc) && (i==K & !axisloc) ) {
      grid.xaxis(main=axisloc, gp=gpar(fontsize=fontsize))
      grid.text(xlab, x=unit(0.5, "npc"), y=unit(1, "npc") + xlaboffset)
    }

    for (j in 1:length(z)) {
      if (z[j]>0) {
        xx <- rep(mids[j], z[j])
        yy <- (1:z[j])/(maxct+3)
        if (use.points) grid.points(unit(xx, "native"), yy, pch=ptpch, size=ptsize)
        else {
          yy <- c(yy, (z[j]+1)/(maxct+3))
          grid.segments(unit(mids[j], "native"), unit(1/(maxct+3), "npc"),
                             unit(mids[j], "native"), unit(max(yy), "npc"))
        }
      }
    }

    popViewport(2)

  }

}

barcode <- function(x,
                    outer.margins=list(bottom=unit(2, "lines"),
                                       left=unit(2, "lines"),
                                       top=unit(2, "lines"),
                                       right=unit(2, "lines")),
                    horizontal=TRUE,
                    nint=0,
                    main="",
                    xlab="",
                    labelloc=TRUE,
                    axisloc=TRUE,
                    labelouter=FALSE,
                    newpage=TRUE,
                    fontsize=9,
                    ptsize=unit(0.25, "char"),
                    ptpch=1,
                    bcspace=NULL,
                    use.points=FALSE) {

  if (!require(grid)) stop("library(grid) is required and unavailable.\n\n")
  if (!require(lattice)) stop("library(lattice) is required and unavailable.\n\n")

  if (!is.null(labelloc)) {
    if (labelloc=="right" | labelloc=="top") labelloc <- FALSE
    if (labelloc=="left" | labelloc=="bottom") labelloc <- TRUE
  }
  if (!is.null(axisloc)) {
    if (axisloc=="right" | axisloc=="top") axisloc <- FALSE
    if (axisloc=="left" | axisloc=="bottom") axisloc <- TRUE
  }

  if (newpage) {
    grid.newpage()
    grid.text(main, 0.5, unit(1, "npc")-unit(1,"lines"), gp=gpar(fontface=2))
  }

  xlaboffset <- unit(2.5, "lines")
  if (!is.null(axisloc) && xlab!="" && !labelouter) {
    if (axisloc) {
      if (horizontal) outer.margins$bottom <- outer.margins$bottom + unit(1.5, "lines")
      else outer.margins$top <- outer.margins$top + unit(1.5, "lines")
    } else {
      if (horizontal) outer.margins$top <- outer.margins$top + unit(1.5, "lines")
      else {
        outer.margins$left <- outer.margins$left + unit(1.5, "lines") ###############
        outer.margins$top <- outer.margins$top + unit(1.5, "lines")
        outer.margins$right <- outer.margins$right - unit(1.5, "lines")
      }
    }
  }
  if (!is.null(axisloc) && !axisloc && main!="" && !labelouter)
    outer.margins$top <- outer.margins$top + unit(2, "lines")
    

  if (horizontal) {
    thisangle <- 0
    thisjust <- c("left", "bottom")
  } else {
    thisangle <- 90
    thisjust <- c("left", "top")
  }
  if (labelouter) {
    outer.margins=list(bottom=unit(0, "lines"),
                                       left=unit(0, "lines"),
                                       top=unit(0, "lines"),
                                       right=unit(0, "lines"))
  }

  vp.main <- viewport(x=outer.margins$left,
                      y=outer.margins$bottom,
                      w=unit(1, "npc")-outer.margins$right-outer.margins$left,
                      h=unit(1, "npc")-outer.margins$top-outer.margins$bottom,
                      just=thisjust, angle=thisangle,
                      name="main", clip="off")
  pushViewport(vp.main)
  grid.rect()
  barcode.panel(x, horizontal=horizontal, nint=nint,
                labelloc=labelloc, axisloc=axisloc, labelouter=labelouter,
                fontsize=fontsize, ptsize=ptsize, bcspace=bcspace,
                xlab=xlab, xlaboffset=xlaboffset, use.points=use.points)
  popViewport(1)

}