

### Copyright (C) 2001-2006  Deepayan Sarkar <Deepayan.Sarkar@R-project.org>
###
### This file is part of the lattice package for R.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
###
### 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.
###
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
### MA 02110-1301, USA









prepanel.default.histogram <-
    function(x,
             breaks = NULL,
             equal.widths = TRUE,
             type = "density",
             nint = round(log2(length(x)) + 1),
             ...)
{
    if (length(x)<1)
        list(xlim = NA,
             ylim = NA,
             dx = NA,
             dy = NA)
    else {
        if (is.factor(x)) {
            isFactor <- TRUE
            xlimits <- levels(x)
        }
        else isFactor <- FALSE
        if (!is.numeric(x)) x <- as.numeric(x)
        if (is.null(breaks)) {
##             nint <- round(log2(length(x)) + 1)
            breaks <-
                if (equal.widths) do.breaks(range(x, finite = TRUE), nint)
                else quantile(x, 0:nint/nint, na.rm = TRUE)
        }
        h <- hist(x, breaks = breaks, plot = FALSE, ...)
        y <-
            if (type == "count") h$counts
            else if (type == "percent") 100 * h$counts/length(x)
            else h$intensities
        xlim <- range(x, finite = TRUE)
        ##lbreak <- max(xlim[1], breaks[breaks<=xlim[1]])
        ##ubreak <- min(xlim[2], breaks[breaks>=xlim[2]])
        ## why ?
        ##list(xlim = range(x, lbreak, ubreak, finite = TRUE),
        list(xlim = if (isFactor) xlimits else range(x, breaks, finite = TRUE),
             ylim = range(0, y, finite = TRUE),
             dx = 1,
             dy = 1)
    }
}









panel.histogram <-
    function(x,
             breaks,
             equal.widths = TRUE,
             type = "density",
             nint = round(log2(length(x)) + 1),
             alpha = plot.polygon$alpha,
             col = plot.polygon$col,
             border = plot.polygon$border,
             lty = plot.polygon$lty,
             lwd = plot.polygon$lwd,
             ...)
{
    x <- as.numeric(x)
    plot.polygon  <- trellis.par.get("plot.polygon")

    grid.lines(x = c(0.05, 0.95),
               y = unit(c(0,0), "native"),
               gp = gpar(col = border, lty = lty, lwd = lwd, alpha = alpha),
               default.units = "npc")
        
    if (length(x)>0)
    {
        if (is.null(breaks))
        {
##             nint <- round(log2(length(x)) + 1)
            breaks <-
                if (equal.widths) do.breaks(range(x, finite = TRUE), nint)
                else quantile(x, 0:nint/nint, na.rm = TRUE)
        }
        h <- hist(x, breaks = breaks, plot = FALSE, ...)
        y <-
            if (type == "count") h$counts
            else if (type == "percent") 100 * h$counts/length(x)
            else h$intensities

        nb <- length(breaks)
        if (length(y) != nb-1) warning("problem with hist computations")

        if (nb>1)
        {
            panel.rect(x = breaks[-nb],
                       y = 0,
                       height = y,
                       width = diff(breaks),
                       col = col, alpha = alpha,
                       border = border, lty = lty,
                       lwd = lwd,
                       just = c("left", "bottom"))
        }
    }
}




histogram <- function(x, data, ...) UseMethod("histogram")


histogram.factor <- histogram.numeric <-
    function(x, data = NULL, xlab = deparse(substitute(x)), ...)
{
    ocall <- ccall <- match.call()
    if (!is.null(ccall$data)) 
        warning("explicit data specification ignored")
    ccall$data <- list(x = x)
    ccall$xlab <- xlab
    ccall$x <- ~x
    ccall[[1]] <- as.name("histogram")
    ans <- eval.parent(ccall)
    ans$call <- ocall
    ans
}





histogram.formula <-
    function(x,
             data = NULL,
             allow.multiple = is.null(groups) || outer,
             outer = TRUE,
             auto.key = FALSE,
             aspect = "fill",
             panel = "panel.histogram",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim,
             ylab,
             ylim,
             type = c("percent", "count", "density"),
             nint = if (is.factor(x)) length(levels(x))
             else round(log2(length(x)) + 1),
             endpoints = extend.limits(range(x, finite = TRUE), prop = 0.04),
             breaks = if (is.factor(x)) seq(0.5, length = length(levels(x))+1)
             else do.breaks(endpoints, nint),
             equal.widths = TRUE,
             drop.unused.levels = lattice.getOption("drop.unused.levels"),
             ...,
             default.scales = list(),
             subscripts = !is.null(groups),
             subset = TRUE)
{
    formula <- x
    dots <- list(...)

    ## Step 1: Evaluate x, y, etc. and do some preprocessing

    groups <- eval(substitute(groups), data, environment(formula))
    subset <- eval(substitute(subset), data, environment(formula))

    form <-
        latticeParseFormula(formula, data, subset = subset,
                            groups = groups, multiple = allow.multiple,
                            outer = outer, subscripts = TRUE,
                            drop = drop.unused.levels)

    groups <- form$groups

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

    if ("subscripts" %in% names(formals(panel))) subscripts <- TRUE
    if (subscripts) subscr <- form$subscr

    prepanel <-
        if (is.function(prepanel)) prepanel 
        else if (is.character(prepanel)) get(prepanel)
        else eval(prepanel)

    cond <- form$condition
    x <- form$right
    if (length(cond) == 0)
    {
        strip <- FALSE
        cond <- list(gl(1, length(x)))
    }
    if (missing(xlab)) xlab <- form$right.name
    if (missing(ylab)) ylab <- TRUE

    ##if(!(is.numeric(x) || is.factor(x)))
    ##    warning("x should be numeric")
    ##x <- as.numeric(x)

    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <-
        do.call("trellis.skeleton",
                c(list(formula = formula, 
                       cond = cond,
                       aspect = aspect,
                       strip = strip,
                       panel = panel,
                       xlab = xlab,
                       ylab = ylab,
                       xlab.default = form$right.name,
                       ylab.default = "dummy"), dots))
                          
    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()

    ## Step 2: Compute scales.common (leaving out limits for now)

    if (is.character(scales)) scales <- list(relation = scales)
    scales <- updateList(default.scales, scales)
    foo <- c(foo, do.call("construct.scales", scales))

    ## Step 3: Decide if limits were specified in call:
    
    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit))
    {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit))
    {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }

    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog)
    {
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)
        
        x <- log(x, xbase)
        if (have.xlim) xlim <- log(xlim, xbase)
    }
    if (have.ylog)
    {
        warning("Can't have log Y-scale")
        have.ylog <- FALSE
        foo$y.scales$log <- FALSE
    }

    ## should type default to density?  Yes when a relative frequency
    ## histogram is going to be misleading

    prefer.density <- 
        ((is.null(breaks) && !equal.widths) ||
         (!is.null(breaks) && {
             ddb <- diff(diff(breaks))
             identical(FALSE, all.equal(ddb, numeric(length(ddb))))
         }))
    if (missing(type) && prefer.density)
        type <- "density"
    type <- match.arg(type)
    if (prefer.density && type != "density")
        warning(gettextf("type='%s' can be misleading in this context", type))

    ## this is normally done earlier (in trellis.skeleton), but in
    ## this case we needed to wait till type is determined

    foo$ylab.default <-
        switch(type,
               count   = gettext("Count"),
               percent = gettext("Percent of Total"),
               density = gettext("Density"))

    ## Step 5: Process cond

    cond.max.level <- unlist(lapply(cond, nlevels))

    ## Step 6: Determine packets

    foo$panel.args.common <-
        c(list(breaks = breaks,
               type = type,
               equal.widths = equal.widths,
               nint = nint),
          dots)
    if (subscripts) foo$panel.args.common$groups <- groups

    npackets <- prod(cond.max.level)
    if (npackets != prod(sapply(foo$condlevels, length))) 
        stop("mismatch in number of packets")
    foo$panel.args <- vector(mode = "list", length = npackets)

    foo$packet.sizes <- numeric(npackets)
    if (npackets > 1)
    {
        dim(foo$packet.sizes) <- sapply(foo$condlevels, length)
        dimnames(foo$packet.sizes) <- lapply(foo$condlevels, as.character)
    }

    cond.current.level <- rep(1, length(cond))

    for (packet.number in seq(length = npackets))
    {
        id <- compute.packet(cond, cond.current.level)
        foo$packet.sizes[packet.number] <- sum(id)

        foo$panel.args[[packet.number]] <- list(x = x[id])
        if (subscripts)
            foo$panel.args[[packet.number]]$subscripts <-
                subscr[id]

        cond.current.level <-
            cupdate(cond.current.level,
                    cond.max.level)
    }

    more.comp <- c(limits.and.aspect(prepanel.default.histogram,
                                     prepanel = prepanel, 
                                     have.xlim = have.xlim, xlim = xlim, 
                                     have.ylim = have.ylim, ylim = ylim, 
                                     x.relation = foo$x.scales$relation,
                                     y.relation = foo$y.scales$relation,
                                     panel.args.common = foo$panel.args.common,
                                     panel.args = foo$panel.args,
                                     aspect = aspect,
                                     npackets = npackets,
                                     x.axs = foo$x.scales$axs,
                                     y.axs = foo$y.scales$axs),
                   cond.orders(foo))
    foo[names(more.comp)] <- more.comp


    if (is.null(foo$legend) && !is.null(groups) &&
        (is.list(auto.key) || (is.logical(auto.key) && auto.key)))
    {
        foo$legend <-
            list(list(fun = "drawSimpleKey",
                      args =
                      updateList(list(text = levels(as.factor(groups)),
                                      points = FALSE,
                                      rectangles = TRUE,
                                      lines = FALSE),
                                 if (is.list(auto.key)) auto.key else list())))
        foo$legend[[1]]$x <- foo$legend[[1]]$args$x
        foo$legend[[1]]$y <- foo$legend[[1]]$args$y
        foo$legend[[1]]$corner <- foo$legend[[1]]$args$corner

        names(foo$legend) <- 
            if (any(c("x", "y", "corner") %in% names(foo$legend[[1]]$args)))
                "inside"
            else
                "top"
        if (!is.null(foo$legend[[1]]$args$space))
            names(foo$legend) <- foo$legend[[1]]$args$space
    }

    class(foo) <- "trellis"
    foo
}
