SCM

SCM Repository

[latticeextra] View of /pkg/R/rootogram.R
ViewVC logotype

View of /pkg/R/rootogram.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 194 - (download) (annotate)
Fri Jan 1 11:17:13 2016 UTC (19 months, 2 weeks ago) by deepayan
File size: 3017 byte(s)
cleanup based on feedback from R CMD check



prepanel.rootogram <-
    function(x, y = table(x),
             dfun = NULL,
             transformation = sqrt,
             hang = TRUE,
             probability = TRUE,
             ...)
{
    stopifnot(is.function(dfun))
    if (probability) y <- y / sum(y)
    yy <- transformation(y)
    xx <- sort(unique(x))
    dotArgs <- list(...)
    dfunArgs <- names(formals(dfun))
    if (!("..." %in% dfunArgs))
        dotArgs <- dotArgs[dfunArgs[-1]]
    dd <- transformation(do.call(dfun, c(list(xx), dotArgs)))
    list(xlim = range(xx),
         ylim =
         if (hang) range(dd, dd-yy, 0)
         else range(dd, yy, 0),
         dx = diff(xx),
         dy = diff(dd))
}


panel.rootogram <-
    function(x, y = table(x),
             dfun = NULL,
             col = plot.line$col,
             lty = plot.line$lty,
             lwd = plot.line$lwd,
             alpha = plot.line$alpha,
             transformation = sqrt,
             hang = TRUE,
             probability = TRUE,
             type = "l", pch = 16,
             ...)
{
    plot.line <- trellis.par.get("plot.line")
    ref.line <- trellis.par.get("reference.line")
    stopifnot(is.function(dfun))
    if (probability) y <- y / sum(y)
    yy <- transformation(y)
    xx <- sort(unique(x))
    dotArgs <- list(...)
    dfunArgs <- names(formals(dfun))
    if (!("..." %in% dfunArgs))
        dotArgs <- dotArgs[dfunArgs[-1]]
    dd <- transformation(do.call(dfun, c(list(xx), dotArgs)))
    panel.abline(h = 0,
                 col = ref.line$col,
                 lty = ref.line$lty,
                 lwd = ref.line$lwd,
                 alpha = ref.line$alpha)
    panel.segments(xx,
                   if (hang) dd else 0,
                   xx,
                   if (hang) (dd - yy) else yy,
                   col = col,
                   lty = lty,
                   lwd = lwd,
                   alpha = alpha,
                   ...)
    if ("l" %in% type) panel.lines(xx, dd)
    if ("p" %in% type) panel.points(xx, dd, pch = pch)
}


rootogram <-
    function(x, ...)
    UseMethod("rootogram")





rootogram.formula <-
    function(x, data = parent.frame(),
             ylab = expression(sqrt(P(X == x))),
             prepanel = prepanel.rootogram,
             panel = panel.rootogram,
             ...,
             probability = TRUE)
{
    if (!probability && missing(ylab)) ylab <- NULL
    if (length(x) == 2) ## formula like ~ x
        foo <-
            densityplot(x, data,
                        prepanel = prepanel,
                        panel = panel,
                        ylab = ylab,
                        ...,
                        probability = probability)
    else ## formula like y ~ x 
        foo <-
            xyplot(x, data,
                   prepanel = prepanel,
                   panel = panel,
                   ylab = ylab,
                   ...,
                   probability = probability)
    foo$call <- sys.call(sys.parent()); foo$call[[1]] <- quote(rootogram)
    foo
}


R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge