


### 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.levelplot <-
    function(x, y, subscripts, ...)
{
    pad <- lattice.getOption("axis.padding")$numeric
    if (length(subscripts) > 0)
    {
        x <- x[subscripts]
        y <- y[subscripts]

        if (is.numeric(x))
        {
            ux <- sort(unique(x[is.finite(x)]))

            if ((ulen <- length(ux)) < 2) xlim <- ux + c(-1, 1)
            else
            {
                ## need to be careful here for DateTime classes
                diffs <- diff(as.numeric(ux))[c(1, ulen-1)]
                xlim <- c(ux[1] - diffs[1] / 2,
                          ux[ulen] + diffs[2] / 2)
            }
        }

        if (is.numeric(y))
        {
            uy <- sort(unique(y[is.finite(y)]))

            if ((ulen <- length(uy)) < 2) ylim <- uy + c(-1, 1)
            else
            {
                ## need to be careful here for DateTime classes
                diffs <- diff(as.numeric(uy))[c(1, ulen-1)]
                ylim <- c(uy[1] - diffs[1] / 2,
                          uy[ulen] + diffs[2] / 2)
            }
        }
        list(xlim = if (is.numeric(x)) extend.limits(xlim, prop = -pad/(1 + 2*pad)) 
             else levels(x),               ##   ^^ these get extended back later

             ylim = if (is.numeric(y)) extend.limits(ylim, prop = -pad/(1 + 2*pad))
             else levels(y),

             dx = if (is.numeric(x)) length(ux) else 1,
             dy = if (is.numeric(y)) length(uy) else 1)
    }
    else
        list(xlim = c(NA, NA),
             ylim = c(NA, NA),
             dx = NA, dy = NA)
}
    


panel.contourplot <- function(...) panel.levelplot(...)


## new version using contourLines, and hopefully to work for missing
## matrix entries as well

panel.levelplot <-
    function(x, y, z, 
             subscripts,
             at = pretty(z),
             shrink,
             labels = NULL,
             label.style = c("mixed", "flat", "align"),
             contour = FALSE,
             region = TRUE,
             col = add.line$col,
             lty = add.line$lty,
             lwd = add.line$lwd,
             cex = add.text$cex,
             font = add.text$font,
             fontfamily = add.text$fontfamily,
             fontface = add.text$fontface,
             col.text = add.text$col,
             ...,
             col.regions = regions$col,
             alpha.regions = regions$alpha)
{
    regions <- trellis.par.get("regions")
    numcol <- length(at) - 1
    numcol.r <- length(col.regions)
    col.regions <-
        if (numcol.r <= numcol)
            rep(col.regions, length = numcol)
        else col.regions[floor(1+(1:numcol-1)*(numcol.r-1)/(numcol-1))]
    zcol <- rep(NA, length(z)) #numeric(length(z))
    for (i in seq(along = col.regions))
        zcol[!is.na(x) & !is.na(y) & !is.na(z) & z>=at[i] & z<at[i+1]] <- i

    label.style <- match.arg(label.style)
    x <- as.numeric(x[subscripts])
    y <- as.numeric(y[subscripts])
    minXwid <- min(diff(sort(unique(x))))
    minYwid <- min(diff(sort(unique(y))))

    fullZrange <- range(as.numeric(z), finite = TRUE) # for shrinking
    z <- as.numeric(z[subscripts])
    zcol <- as.numeric(zcol[subscripts])

    ## Do we need a zlim-like argument ?

    shrinkx <- c(1, 1)
    shrinky <- c(1, 1)
    if (!missing(shrink)) {
        if (is.numeric(shrink)) {
            shrinkx <- rep(shrink, length = 2)
            shrinky <- rep(shrink, length = 2)
        }
        else if (is.list(shrink)) {
            shrinkx <- rep(shrink[[1]], length = 2)
            shrinky <- rep(shrink[[1]], length = 2)
            if ("x" %in% names(shrink)) shrinkx <- rep(shrink$x, length = 2)
            if ("y" %in% names(shrink)) shrinky <- rep(shrink$y, length = 2)
        }
        else warning("Invalid shrink, ignored")
    }

    scaleWidth <- function(z, min = .8, max = .8, zl = range(z, finite = TRUE)) {
        if (diff(zl) == 0) rep(.5 * (min + max), length(z))
        else min + (max - min) * (z - zl[1]) / diff(zl)
    }

    
    if (any(subscripts)) {

        ## sorted unique values of x 
        ux <- sort(unique(x[!is.na(x)]))
        ## actual box boundaries (x axis)
        bx <-
            if (length(ux) > 1)
                c(3 * ux[1] - ux[2],
                  ux[-length(ux)] + ux[-1],
                  3 * ux[length(ux)] - ux[length(ux)-1]) / 2
            else
                ux + c(-.5, .5) * minXwid
        ## dimension of rectangles
        lx <- diff(bx)
        ## centers of rectangles
        cx <- (bx[-1] + bx[-length(bx)])/2

        ## same things for y
        uy <- sort(unique(y[!is.na(y)]))
        by <-
            if (length(uy) > 1)
                c(3 * uy[1] - uy[2],
                  uy[-length(uy)] + uy[-1],
                  3 * uy[length(uy)] - uy[length(uy)-1]) / 2
            else
                uy + c(-.5, .5) * minYwid
        ly <- diff(by)
        cy <- (by[-1] + by[-length(by)])/2


        idx <- match(x, ux)
        idy <- match(y, uy)

        if (region) 
            grid.rect(x = cx[idx],
                      y = cy[idy],
                      width = lx[idx] *
                      scaleWidth(z, shrinkx[1], shrinkx[2], fullZrange),
                      height = ly[idy] *
                      scaleWidth(z, shrinky[1], shrinky[2], fullZrange),
                      default.units = "native",
                      gp =
                      gpar(fill = col.regions[zcol],
                           lwd = 0.00001,
                           col = "transparent",
                           alpha = alpha.regions))

        if (contour)
        {
            ## Processing the labels argument
            if (is.logical(labels) && !labels) labels <- NULL
            else
            {
                if (is.logical(labels)) labels <- format(at, trim = TRUE)
                text <- trellis.par.get("add.text") # something better ?
                tmp <- list(label = if (is.list(labels)) labels[[1]] else labels,
                            col = text$col, rot = text$rot,
                            cex = text$cex,
                            fontfamily = text$fontfamily,
                            fontface = text$fontface,
                            font = text$font)

                labels <-
                    updateList(tmp,
                               if (is.list(labels)) labels
                               else list()) # FIXME: risky

                if (!is.characterOrExpression(labels$label))
                    labels$label <- format(at)
            }

            add.line <- trellis.par.get("add.line")
            add.text <- trellis.par.get("add.text")

            ## convert z into a matrix, with NA entries for those
            ## 'missing' from data frame. There's scope for ambiguity
            ## here, which can be avoided by the user.

            m <- matrix(NA, nrow = length(ux), ncol = length(uy))
            m[(idy - 1) * length(ux) + idx ] <- z

            clines <-
                contourLines(x = ux, y = uy, z = m,
                             nlevels = length(at), ## necessary ?
                             levels = at)

            for (val in clines) {

                ## each val looks like:

                ## $ :List of 3
                ##  ..$ level: num 170
                ##  ..$ x    : num [1:21] 0.535 0.534 0.534 0.534 0.535 ...
                ##  ..$ y    : num [1:21] 0.398 0.400 0.417 0.433 0.434 ...

                ## we don't know how to leave gap in lines for labels.

                llines(val, ## hopefully $levels won't matter
                       col = col, lty = lty, lwd = lwd)


                ## if too small, don't add label. How small is small ?
                ## Should depend on resolution. How ?

                if (length(val$x) > 5)
                {
                    if (!is.null(labels))
                    {
                        slopes <- diff(val$y) / diff(val$x)
                        ## slopes[is.na(slopes)] <- 0

                        if (label.style == "flat")
                        {
                            ## draw label at 'flattest' position along contour

                            textloc <- which.min(abs(slopes))
                            rotangle <- 0
                        }
                        else if (label.style == "align")
                        {

                            ## draw label at 'deepest' position along
                            ## contour, depth being min distance to either
                            ## of the four edges, scaled appropriately

                            rx <- range(ux)
                            ry <- range(uy)
                            depth <- pmin(pmin(val$x - rx[1], rx[2] - val$x) / diff(rx), 
                                          pmin(val$y - ry[1], ry[2] - val$y) / diff(ry))
                            textloc <- min(which.max(depth), length(slopes)) 
                                        # slopes has one less entry,
                                        # and textloc indexes slopes

                            rotangle <- atan(slopes[textloc] * diff(rx) / diff(ry)) * 180 / base::pi
                        }
                        else if (label.style == "mixed")
                        {

                            ## mix both. align for contours whose flattest
                            ## portion is too close to edge

                            rx <- range(ux)
                            ry <- range(uy)
                            depth <- pmin(pmin(val$x - rx[1], rx[2] - val$x) / diff(rx), 
                                          pmin(val$y - ry[1], ry[2] - val$y) / diff(ry))
                            textloc <- which.min(abs(slopes))
                            rotangle <- 0


                            if (depth[textloc] < .05 ) {
                                textloc <- min(which.max(depth), length(slopes))
                                rotangle <- atan(slopes[textloc] * diff(rx) / diff(ry)) * 180 / base::pi
                            }

                        }
                        else stop("Invalid label.style")

                        i <- match(val$level, at)

                        
                        ltext(lab = labels$lab[i], adj = c(.5, 0),
                              srt = rotangle,
                              col = labels$col,
                              cex = labels$cex,
                              font = labels$font,
                              fontfamily = labels$fontfamily,
                              fontface = labels$fontface,
                              x = .5 * (val$x[textloc]+val$x[textloc + 1]),
                              y = .5 * (val$y[textloc]+val$y[textloc + 1]))

                    }
                }
            }
        }
    }
}


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



contourplot.matrix <-
    function(x, data = NULL, aspect = "iso", ...)
{
    if (!missing(data)) warning("explicit data specification ignored")
    form <- z ~ row * column
    data <-
        expand.grid(row = seq(length = nrow(x)),
                    column = seq(length = ncol(x)))
    data$z <- as.vector(as.numeric(x))
    ## if rownames/colnames are non-null, make them factors
    if (!is.null(rownames(x)))
        data$row <- factor(data$row, labels = rownames(x))
    if (!is.null(colnames(x)))
        data$column <- factor(data$column, labels = colnames(x))
    contourplot(form, data, aspect = aspect, ...)
}



contourplot.formula <-
    function(x,
             data = NULL,
             panel = "panel.contourplot",
             cuts = 7,
             labels = TRUE,
             contour = TRUE,
             pretty = TRUE,
             region = FALSE,
             ...)
{
    ocall <- ccall <- match.call()
    ccall$data <- data
    ccall$panel <- panel
    ccall$cuts <- cuts
    ccall$labels <- labels
    ccall$contour <- contour
    ccall$pretty <- pretty
    ccall$region <- region
    ccall[[1]] <- as.name("levelplot")
    ans <- eval.parent(ccall)
    ans$call <- ocall
    ans
}




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

levelplot.matrix <-
    function(x, data = NULL, aspect = "iso", ...)
{
    if (!missing(data)) warning("explicit data specification ignored")
    form <- z ~ row * column
    data <-
        expand.grid(row = seq(length = nrow(x)),
                    column = seq(length = ncol(x)))
    data$z <- as.vector(as.numeric(x))
    ## if rownames/colnames are non-null, make them factors
    if (!is.null(rownames(x)))
        data$row <- factor(data$row, labels = rownames(x))
    if (!is.null(colnames(x)))
        data$column <- factor(data$column, labels = colnames(x))
    levelplot(form, data, aspect = aspect, ...)
}

levelplot.formula <-
    function(x,
             data = NULL,
             allow.multiple = is.null(groups) || outer,
             outer = TRUE,
             aspect = "fill",
             panel = "panel.levelplot",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim,
             ylab,
             ylim,

             ## at, region etc should be ideally in panel.levelplot only, but is needed for colorkey
             at,
             cuts = 15,
             pretty = FALSE,
             region = TRUE,
             drop.unused.levels = lattice.getOption("drop.unused.levels"),
             ...,
             default.scales = list(),
             colorkey = region,
             col.regions,
             alpha.regions,
             subset = TRUE)
{
    formula <- x
    dots <- list(...)
    groups <- eval(substitute(groups), data, environment(formula))
    subset <- eval(substitute(subset), data, environment(formula))

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

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

    ## We need to be careful with 'subscripts' here. It HAS to be
    ## there, and it's to be used to index x, y, z (and not only
    ## groups, unlike in xyplot etc). This means we have to subset
    ## groups as well, which is about the only use for the subscripts
    ## calculated in latticeParseFormula, after which subscripts is
    ## regenerated as a straight sequence indexing the variables

    if (!is.null(form$groups))
        groups <-
            if (is.matrix(form$groups)) as.vector(form$groups)[form$subscr]
            else if (is.data.frame(form$groups)) as.vector(as.matrix(form$groups))[form$subscr]
            else form$groups[form$subscr]

    subscr <- seq(length = length(form$left))

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

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

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

    zrng <- extend.limits(range(as.numeric(z), finite = TRUE))
    if (missing(at))
        at <-
            if (pretty) pretty(zrng, cuts)
            else seq(zrng[1], zrng[2], length = cuts + 2)
    
    ## 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.x.name,
                       ylab.default = form$right.y.name), dots))

    
    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()

    ## Step 2: Compute scales.common (excluding limits)

    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)
    {
        ylog <- foo$y.scales$log
        ybase <-
            if (is.logical(ylog)) 10
            else if (is.numeric(ylog)) ylog
            else if (ylog == "e") exp(1)

        y <- log(y, ybase)
        if (have.ylim) ylim <- log(ylim, ybase)
    }
    
    ## Step 5: Process cond

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

    ## Most levelplot/contourplot specific code here

    if (is.logical(colorkey))
    {
        if (colorkey)
        {
            colorkey <- list(at = at, space = "right")
            if (!missing(col.regions)) colorkey$col <- col.regions
            if (!missing(alpha.regions)) colorkey$alpha <- alpha.regions
        }
        else colorkey <- NULL
    }
    else if (is.list(colorkey))
    {
        tmp <- ## FIXME: does the inside thing work? probably not 
            list(space = if (any(c("x", "y", "corner") %in% names(colorkey))) "inside" else "right",
                 at = at)
        if (!missing(col.regions)) tmp$col <- col.regions
        if (!missing(alpha.regions)) tmp$alpha <- alpha.regions
        colorkey <- updateList(tmp, colorkey)
    }
    foo$legend <-
        construct.legend(foo$legend,
                         colorkey,
                         fun = "draw.colorkey")

    ## Step 6: Determine packets

    foo$panel.args.common <-
        c(list(x = x, y = y, z = z, at = at,
               region = region), dots)
    if (!missing(col.regions)) foo$panel.args.common$col.regions <- col.regions
    if (!missing(alpha.regions)) foo$panel.args.common$alpha.regions <- alpha.regions



# ############### premature calculation of col.regions
#     ## region
#     numcol <- length(at)-1
#     numcol.r <- length(col.regions)

#     col.regions <-
#         if (numcol.r <= numcol)
#             rep(col.regions, length = numcol)
#         else col.regions[floor(1+(1:numcol-1)*(numcol.r-1)/(numcol-1))]

#     if (is.logical(colorkey))
#     {
#         if (colorkey) colorkey <-
#             list(space = "right", col = col.regions,
#                  at = at, tick.number = 7)
#         else colorkey <- NULL
#     }
#     else if (is.list(colorkey))
#     {
#         #foo$colorkey <- colorkey
#         if (is.null(colorkey$col)) colorkey$col <- col.regions
#         if (is.null(colorkey$at)) colorkey$at <- at
#         if (is.null(colorkey$space)) colorkey$space <-
#             if (any(c("x", "y", "corner") %in% names(colorkey))) "inside" else "right"
#     }
#     foo$legend <-
#         construct.legend(foo$legend,
#                          colorkey,
#                          fun = "draw.colorkey")

#     zcol <- rep(NA, length(z)) #numeric(length(z))
#     for (i in seq(along=col.regions))
#         zcol[!id.na & !is.na(z) & z>=at[i] & z<at[i+1]] <- i

#     foo$panel.args.common <-
#         c(list(x=x, y=y, z=z, at=at,
#                labels=labels,
#                region = region, contour = contour,
#                zcol=zcol,
#                col.regions=col.regions),
#           dots)
# ##############################


    if (!is.null(groups)) 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(subscripts = subscr[id])

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

    more.comp <-
        c(limits.and.aspect(prepanel.default.levelplot,
                            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

    class(foo) <- "trellis"
    foo
}

