

### 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

## the foll functions don't do much error checking yet



panel.abline <-
    function(a, b = NULL,
             h = numeric(0),
             v = numeric(0),
             col,
             col.line = add.line$col,
             lty = add.line$lty,
             lwd = add.line$lwd,
             type, ...)
{
    add.line <- trellis.par.get("add.line")
    if (!missing(col) && missing(col.line)) col.line <- col
    if (!missing(a))
    {
        coeff <- 
            if (inherits(a,"lm")) coef(a)
            else if (!is.null(coef(a))) coef(a)  # ????
            else c(a,b)

        if (length(coeff) == 1) coeff <- c(0, coeff)

        if (coeff[2] == 0) h <- c(h, coeff[1])
        else if (!any(is.null(coeff)))
        {
            xx <- current.viewport()$xscale
            yy <- current.viewport()$yscale
            
            x <- numeric(0)
            y <- numeric(0)
            ll <- function(i, j, k, l)
                (yy[j]-coeff[1]-coeff[2]*xx[i]) *
                    (yy[l]-coeff[1]-coeff[2]*xx[k])
            
            if (ll(1,1,2,1)<=0) {
                y <- c(y, yy[1])
                x <- c(x, (yy[1]-coeff[1])/coeff[2])
            }
            
            if (ll(2,1,2,2)<=0) {
                x <- c(x, xx[2])
                y <- c(y, coeff[1] + coeff[2] * xx[2])
            }
            
            if (ll(2,2,1,2)<=0) {
                y <- c(y, yy[2])
                x <- c(x, (yy[2]-coeff[1])/coeff[2])
            }
            
            if (ll(1,2,1,1)<=0) {
                x <- c(x, xx[1])
                y <- c(y, coeff[1] + coeff[2] * xx[1])
            }

            panel.lines(x = x, y = y, 
                        col = col.line,
                        lty = lty,
                        lwd = lwd,
                        ...)
        }
    }

    if (length(h <- as.numeric(h)))
        grid.segments(y0 = h, y1 = h, default.units="native",
                      gp = gpar(col = col.line, lty = lty, lwd = lwd))
    if (length(as.numeric(v)))
        grid.segments(x0 = v, x1 = v, default.units="native",
                      gp = gpar(col = col.line, lty = lty, lwd = lwd))
}




panel.curve <-
    function (expr, from, to, n = 101,
              curve.type = "l",
              col = add.line$col,
              lty = add.line$lty,
              lwd = add.line$lwd,
              type, ## ignored, to avoid type meant for panel.xyplot etc
              ...)
    ## curve has a log option. Unfortunately there is no easy way to
    ## read in the lattice log options (specified via scales) into the
    ## panel function. Maybe some day if grid natively supports log
    ## scales and lattice is redesigned to take advantage of that
{
    add.line <- trellis.par.get("add.line")
    sexpr <- substitute(expr)
    if (is.name(sexpr))
    {
        fcall <- paste(sexpr, "(x)")
        expr <- parse(text = fcall)
    }
    else
    {
        if (!(is.call(sexpr) && match("x", all.vars(sexpr), nomatch = 0))) 
            stop("'expr' must be a function or an expression containing 'x'")
        expr <- sexpr
    }
    lims <- current.panel.limits()$xlim
    if (missing(from)) from <- lims[1]
    if (missing(to)) to <- lims[2]
    x <- seq(from, to, length = n)
    y <- eval(expr, envir = list(x = x), enclos = parent.frame())
    panel.lines(x, y, type = curve.type, col = col, lty = lty, lwd = lwd, ...)
}






panel.rug <-
    function(x = NULL, y = NULL,
             regular = TRUE, 
             start = if (regular) 0 else 0.97,
             end = if (regular) 0.03 else 1,
             x.units = rep("npc", 2),
             y.units = rep("npc", 2),
             col = plot.line$col,
             lty = plot.line$lty,
             lwd = plot.line$lwd,
             alpha = plot.line$alpha,
             ...)
{
    if (!any(is.finite(x))) x <- NULL
    if (!any(is.finite(y))) y <- NULL
    plot.line <- trellis.par.get("plot.line")
    x.units <- rep(x.units, length = 2)
    y.units <- rep(y.units, length = 2)
    if (!is.null(x))
    {
        grid.segments(x0 = unit(x, "native"), x1 = unit(x, "native"),
                      y0 = unit(start, x.units[1]), y1 = unit(end, x.units[2]),
                      gp =
                      gpar(col = col, lty = lty,
                           lwd = lwd, alpha = alpha))
    }
    if (!is.null(y))
    {
        grid.segments(y0 = unit(y, "native"), y1 = unit(y, "native"),
                      x0 = unit(start, y.units[1]), x1 = unit(end, y.units[2]),
                      gp =
                      gpar(col = col, lty = lty,
                           lwd = lwd, alpha = alpha))
    }
}





panel.fill <-
    function(col = trellis.par.get("background")$col,
             border = "transparent", ...)
{
    grid.rect(gp =
              gpar(fill = col,
                   col = border,
                   ...))
}












panel.grid <-
    function(h = 3, v = 3,
             col,
             col.line = reference.line$col,
             lty = reference.line$lty,
             lwd = reference.line$lwd, ...)
{
    reference.line <- trellis.par.get("reference.line")
    if (!missing(col) && missing(col.line)) col.line <- col
    h <- as.integer(h)
    v <- as.integer(v)

    if (h > 0)
        grid.segments(y0 = 1:h / (h+1),
                      y1 = 1:h / (h+1),
                      gp = gpar(col = col.line, lty = lty, lwd = lwd),
                      default.units = "npc",
                      name = trellis.grobname("panel.grid.h"))

##         for(i in 1:h)
##             grid.lines(y=rep(i/(h+1),2),
##                        gp = gpar(col = col.line, lty = lty, lwd = lwd),
##                        default.units="npc")

    if (v > 0)
        grid.segments(x0 = 1:v / (v+1),
                      x1 = 1:v / (v+1),
                      gp = gpar(col = col.line, lty = lty, lwd = lwd),
                      default.units = "npc",
                      name = trellis.grobname("panel.grid.v"))
        
##         for(i in 1:v)
##             grid.lines(x=rep(i/(v+1),2),
##                        gp = gpar(col = col.line, lty = lty, lwd = lwd),
##                        default.units="npc")


    ## Cheating here a bit for h=-1, v=-1. Can't think of any neat way to
    ## get the actual `at' values of the panel (Can pass it in though)

    limits <- current.panel.limits()

    if (h < 0)
    {
        scale <- limits$ylim
        at <- pretty(scale)
        at <- at[at > scale[1] & at < scale[2]]
        grid.segments(y0 = at,
                      y1 = at,
                      gp = gpar(col = col.line, lty = lty, lwd = lwd),
                      default.units = "native",
                      name = trellis.grobname("panel.grid.h"))
    }
    if (v < 0)
    {
        scale <- limits$xlim
        at <- pretty(scale)
        at <- at[at > scale[1] & at < scale[2]]
        grid.segments(x0 = at,
                      x1 = at,
                      gp = gpar(col = col.line, lty = lty, lwd = lwd),
                      default.units = "native",
                      name = trellis.grobname("panel.grid.v"))
    }
}





panel.lmline <-
    function(x, y, ...)
{
    if (length(x) > 0) panel.abline(lm(as.numeric(y) ~ as.numeric(x)), ...) 
}


prepanel.lmline <-
    function(x, y, ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)

    if (length(x)>0) {
        coeff <- coef(lm(y~x))
        tem <- coeff[1] + coeff[2] * range(x, finite = TRUE)
        list(xlim = range(x, finite = TRUE),
             ylim = range(y, tem, finite = TRUE), 
             dx = diff(range(x, finite = TRUE)),
             dy = diff(tem, finite = TRUE))
    }
    else list(xlim=c(NA,NA), ylim=c(NA,NA), dx=NA, dy=NA)
}










panel.loess <-
    function(x, y, span = 2/3, degree = 1,
             family = c("symmetric", "gaussian"),
             evaluation = 50,
             lwd = plot.line$lwd,
             lty = plot.line$lty,
             col,
             col.line = plot.line$col,
             type, ## ignored
             ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)
    if (length(x)>0)
    {
        if (!missing(col))
        {
            if (missing(col.line)) col.line <- col
        }
        plot.line <- trellis.par.get("plot.line")
        smooth <-
            loess.smooth(x, y, span = span, family = family,
                         degree = degree, evaluation = evaluation)
        panel.lines(x = smooth$x,
                    y = smooth$y, 
                    col = col.line,
                    lty = lty,
                    lwd = lwd,
                    ...)
    }
}


prepanel.loess <-
    function(x, y, span = 2/3, degree = 1,
             family = c("symmetric", "gaussian"),
             evaluation = 50,
             ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)
    if (length(x)>0)
    {
        smooth <-
            loess.smooth(x, y, span = span, family = family,
                         degree = degree, evaluation = evaluation)
        list(xlim = range(x, smooth$x, finite = TRUE),
             ylim = range(y, smooth$y, finite = TRUE),
             dx = diff(smooth$x),
             dy = diff(smooth$y))
    }
    else list(xlim = c(NA, NA),
              ylim = c(NA, NA),
              dx = NA, dy = NA)
}



# panel.smooth <-
#     function(x, y, span = 2/3, degree = 1, zero.line = FALSE,
#              family = c("symmetric", "gaussian"),
#              evaluation = 50,
#              lwd = plot.line$lwd, lty = plot.line$lty,
#              col = plot.line$col, ...)
# {
#     if (zero.line) abline(h=0, ...)
#     panel.loess(x, y, span = span, family = family,
#                 degree = degree, evaluation = evaluation, ...)
#     panel.xyplot(x, y, ...)
# }
## base R function exists




panel.superpose <-
    function(x, y = NULL, subscripts, groups,
             panel.groups = "panel.xyplot",
             col = NA,
             col.line = superpose.line$col,
             col.symbol = superpose.symbol$col,
             pch = superpose.symbol$pch,
             cex = superpose.symbol$cex, 
             fill = superpose.symbol$fill, 
             font = superpose.symbol$font, 
             fontface = superpose.symbol$fontface, 
             fontfamily = superpose.symbol$fontfamily, 
             lty = superpose.line$lty,
             lwd = superpose.line$lwd,
             alpha = superpose.symbol$alpha,
             type = 'p',
             ...,
             distribute.type = FALSE)
{
    if (distribute.type)
    {

        ## This implies a slightly different behaviour: the 'type'
        ## argument behaves like other graphical parameters, i.e., it
        ## is repeated to be as long as the number of groups, and one
        ## used for each group.  This is the default behaviour of
        ## panel.superpose in S-PLUS.  The lattice default
        ## (!distribute.type) is to use all type values concurrently
        ## for each group.  We accomplish this by transforming 'type'
        ## to a list in either case (but in different ways) and then
        ## use common code.

        ## have.type <- FALSE
        type <- as.list(type)
    }
    else 
    {
        ## this is something of a hack, needed because without this,
        ## grouped displays with 'g' %in% type may draw a grid
        ## (courtesy of panel.groups) for each group, overwriting
        ## earlier ones.

        ## have.type <- TRUE
        type <- unique(type)
        wg <- match('g', type, nomatch = NA)
        if (!is.na(wg))
        {
            panel.grid(h = -1, v = -1)
            type <- type[-wg]
        }
        type <- list(type)
    }
    x <- as.numeric(x)
    if (!is.null(y)) y <- as.numeric(y)
    if (length(x) > 0)
    {
        if (!missing(col))
        {
            if (missing(col.line)) col.line <- col
            if (missing(col.symbol)) col.symbol <- col
        }
        superpose.symbol <- trellis.par.get("superpose.symbol")
        superpose.line <- trellis.par.get("superpose.line")
        vals <-
            if (is.factor(groups)) levels(groups)
            else sort(unique(groups))
        nvals <- length(vals)
        col <- rep(col, length = nvals)
        col.line <- rep(col.line, length = nvals)
        col.symbol <- rep(col.symbol, length = nvals)
        pch <- rep(pch, length = nvals)
        fill <- rep(fill, length = nvals)
        lty <- rep(lty, length = nvals)
        lwd <- rep(lwd, length = nvals)
        alpha <- rep(alpha, length = nvals)
        cex <- rep(cex, length = nvals)
        font <- rep(font, length = nvals)
        fontface <- rep(fontface, length = nvals)
        fontfamily <- rep(fontfamily, length = nvals)
        type <- rep(type, length = nvals)

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

        subg <- groups[subscripts]
        ok <- !is.na(subg)
        for (i in seq(along = vals))
        {
            id <- ok & (subg == vals[i])
            if (any(id))
            {
                args <-
                    list(x = x[id],
                         ## groups = groups,
                         subscripts = subscripts[id],
                         pch = pch[i], cex = cex[i],
                         font = font[i],
                         fontface = fontface[i],
                         fontfamily = fontfamily[i],
                         col = col[i],
                         col.line = col.line[i],
                         col.symbol = col.symbol[i],
                         fill = fill[i],
                         lty = lty[i],
                         lwd = lwd[i],
                         alpha = alpha[i],
                         type = type[[i]],
                         group.number = i,
                         ...)
                ## if (have.type) args$type <- type
                if (!is.null(y)) args$y <- y[id]
                do.call(panel.groups, args)
            }
        }
    }
}



panel.superpose.2 <-
    function(..., distribute.type = TRUE)
{
    panel.superpose(...,
                    distribute.type = distribute.type)
}


## panel.superpose.2 <-
##     function(x, y = NULL, subscripts, groups,
##              panel.groups = "panel.xyplot",
##              col,
##              col.line = superpose.line$col,
##              col.symbol = superpose.symbol$col,
##              pch = superpose.symbol$pch,
##              cex = superpose.symbol$cex, 
##              font = superpose.symbol$font, 
##              fontface = superpose.symbol$fontface, 
##              fontfamily = superpose.symbol$fontfamily, 
##              lty = superpose.line$lty,
##              lwd = superpose.line$lwd,
##              alpha = superpose.symbol$alpha,
##              type = "p",
##              ...)
## {

##     ## This is a slightly different version of panel.superpose.  It
##     ## has an explicit type argument which behaves like other
##     ## graphical parameters, i.e., it is repeated to be as long as the
##     ## number of groups, and one used for each group.  This is the
##     ## default behaviour of panel.superpose in S-PLUS.

##     ## Original version contributed by Neil Klepeis

##     type <- as.list(type)

##     x <- as.numeric(x)
##     if (!is.null(y)) y <- as.numeric(y)

##     if (length(x)>0)
##     {
##         if (!missing(col))
##         {
##             if (missing(col.line)) col.line <- col
##             if (missing(col.symbol)) col.symbol <- col
##         }

##         superpose.symbol <- trellis.par.get("superpose.symbol")
##         superpose.line <- trellis.par.get("superpose.line")

##         vals <-
##             if (is.factor(groups)) levels(groups)
##             else sort(unique(groups))
##         nvals <- length(vals)
##         col.line <- rep(col.line, length = nvals)
##         col.symbol <- rep(col.symbol, length = nvals)
##         pch <- rep(pch, length = nvals)
##         lty <- rep(lty, length = nvals)
##         lwd <- rep(lwd, length = nvals)
##         alpha <- rep(alpha, length = nvals)
##         cex <- rep(cex, length = nvals)
##         font <- rep(font, length = nvals)
##         fontface <- rep(fontface, length = nvals)
##         fontfamily <- rep(fontfamily, length = nvals)
##         type <- rep(type, length = nvals)

##         panel.groups <- 
##             if (is.function(panel.groups)) panel.groups
##             else if (is.character(panel.groups)) get(panel.groups)
##             else eval(panel.groups)

##         subg <- groups[subscripts]
##         ok <- !is.na(subg)
##         for (i in seq(along = vals))
##         {
##             id <- ok & (subg == vals[i])
##             if (any(id))
##             {
##                 args <-
##                     list(x=x[id],
##                          groups = groups,
##                          subscripts = subscripts[id],
##                          pch = pch[i], cex = cex[i],
##                          font = font[i],
##                          fontface = fontface[i],
##                          fontfamily = fontfamily[i],
##                          col.line = col.line[i],
##                          col.symbol = col.symbol[i],
##                          lty = lty[i],
##                          lwd = lwd[i],
##                          alpha = alpha[i],
##                          type = type[[i]], ...)
##                 if (!is.null(y)) args$y <- y[id]

##                 do.call(panel.groups, args)
##             }
##         }
##     }
## }





# panel.superpose.2 <- 
#     function(x, y, subscripts, groups,
#              col, col.line = superpose.line$col,
#              col.symbol = superpose.symbol$col,
#              pch = superpose.symbol$pch,
#              cex = superpose.symbol$cex,
#              lty = superpose.line$lty,
#              lwd = superpose.line$lwd, type="p", ...)
# {
    
#     ## `panel.superpose.2' : This is a version of the
#     ## 'panel.superpose' Trellis panel function that allows the plot
#     ## `type' to change between superimposed (overlayed) data sets.
#     ## See the `panel.xyplot' function for details on the `type'
#     ## option which is usually a single character, but here is a
#     ## character vector with each element specifying the plot style of
#     ## each subsequently-overlayed plot.  --- Neil Klepeis,
#     ## 26-Dec-2001
    
#     x <- as.numeric(x)
#     y <- as.numeric(y)

#     if (length(x) > 0) {
#         if (!missing(col)) {
#             if (missing(col.line))
#                 col.line <- col
#             if (missing(col.symbol))
#                 col.symbol <- col
#         }
#         superpose.symbol <- trellis.par.get("superpose.symbol")
#         superpose.line <- trellis.par.get("superpose.line")
#         x <- as.numeric(x)
#         y <- as.numeric(y)
#         vals <-
#             if (is.factor(groups)) levels(groups)
#             else sort(unique(groups))
#         nvals <- length(vals)
#         col.line <- rep(col.line, length = nvals)
#         col.symbol <- rep(col.symbol, length = nvals)
#         pch <- rep(pch, length = nvals)
#         lty <- rep(lty, length = nvals)
#         lwd <- rep(lwd, length = nvals)
#         cex <- rep(cex, length = nvals)
#         type <- rep(type, length = nvals)      # new line here
#         for (i in seq(along = vals)) {
#             id <- (groups[subscripts] == vals[i])
#             if (any(id))
#                 panel.xyplot(x = x[id], y = y[id], pch = pch[i],
#                   cex = cex[i], col.line = col.line[i], col.symbol = col.symbol[i],
#                   lty = lty[i], lwd = lwd[i], type=type[i], ...)
#         }
#     }
# }







panel.linejoin <-
    function(x, y, fun = mean,
             horizontal = TRUE,
             lwd = reference.line$lwd,
             lty = reference.line$lty,
             col,
             col.line = reference.line$col,
             type,
             ...)
{
    ## FIXME: pretty sure this can be made more readable using tapply
    x <- as.numeric(x)
    y <- as.numeric(y)

    reference.line = trellis.par.get("reference.line")
    if (!missing(col))
    {
        if (missing(col.line)) col.line <- col
    }
    if (horizontal)
    {
        vals <- unique(sort(y))
        yy <- seq(along = vals)
        xx <- numeric(length(yy))
        for (i in yy)
            xx[i] <- fun(x[y == vals[i]])
        panel.lines(xx, vals[yy], col = col.line, lty = lty, lwd = lwd, ...)
    }
    else
    {
        vals <- unique(sort(x))
        xx <- seq(along = vals)
        yy <- numeric(length(xx))
        for (i in xx)
            yy[i] <- fun(y[x == vals[i]])
        panel.lines(vals[xx], yy, col = col.line, lty = lty, lwd = lwd, ...)
     }
}



panel.mathdensity <-
    function(dmath = dnorm,
             args = list(mean = 0, sd = 1),
             n = 50,
             col,
             col.line = reference.line$col,
             lwd = reference.line$lwd,
             lty = reference.line$lty,
             type,
             ...)
{
    reference.line <- trellis.par.get("reference.line")
    if (!missing(col) && missing(col.line)) col.line <- col
    x <- do.breaks(endpoints = current.panel.limits()$xlim, nint = n)
    y <- do.call("dmath", c(list(x = x), args))
    panel.lines(x = x, y = y, col = col.line, lwd = lwd, lty = lty, ...)
}

