SCM

SCM Repository

[latticeextra] Annotation of /pkg/R/panel.xyarea.R
ViewVC logotype

Annotation of /pkg/R/panel.xyarea.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 194 - (view) (download)

1 : felix 148 ##
2 :     ## Copyright (c) 2008 Felix Andrews <felix@nfrac.org>
3 :     ##
4 :    
5 :     panel.xyarea <- function(x, ...)
6 :     UseMethod("panel.xyarea")
7 :    
8 :     ## Plot a series as a filled polygon connected at given origin (on y axis).
9 :     ## With groups, acts like panel.superpose, but with polygon style settings.
10 :     panel.xyarea.default <-
11 : felix 167 function(x, y, groups = NULL, origin = NULL, horizontal = FALSE,
12 : felix 148 col = if (is.null(groups)) plot.polygon$col else superpose.polygon$col,
13 : felix 179 col.line = if (is.null(groups)) plot.polygon$col else superpose.polygon$col,
14 : felix 148 border = if (is.null(groups)) plot.polygon$border else superpose.polygon$border,
15 :     lty = if (is.null(groups)) plot.polygon$lty else superpose.polygon$lty,
16 :     lwd = if (is.null(groups)) plot.polygon$lwd else superpose.polygon$lwd,
17 :     alpha = if (is.null(groups)) plot.polygon$alpha else superpose.polygon$alpha,
18 : felix 179 ..., fill, panel.groups = panel.xyarea)
19 : felix 148 {
20 :     plot.polygon <- trellis.par.get("plot.polygon")
21 :     superpose.polygon <- trellis.par.get("superpose.polygon")
22 :     x <- as.numeric(x)
23 :     y <- as.numeric(y)
24 :     if (length(x) == 0) return()
25 :     if (!is.null(groups)) {
26 :     ## NOTE superpose does not handle 'border' argument, so pass it as col.line
27 :     panel.superpose(x, y, ..., groups = groups, panel.groups = panel.groups,
28 : felix 179 col = col, col.line = col.line, lty = lty, lwd = lwd, border = border,
29 : felix 167 alpha = alpha, origin = origin, horizontal = horizontal)
30 : felix 148 } else {
31 : felix 175 if (!missing(col.line))
32 : felix 148 col <- col.line
33 : felix 167 if (horizontal == TRUE) {
34 :     ## actually means origin is vertical. for consistency with panel.xyplot.
35 :     xlim <- current.panel.limits()$xlim
36 :     if (is.null(origin))
37 :     origin <- xlim[1]
38 :     infi <- is.infinite(x)
39 :     x[infi] <- ifelse(x[infi] > 0, max(xlim), min(xlim))
40 :     } else {
41 :     ## default case; origin is horizontal
42 :     ylim <- current.panel.limits()$ylim
43 :     if (is.null(origin))
44 :     origin <- ylim[1]
45 :     infi <- is.infinite(y)
46 :     y[infi] <- ifelse(y[infi] > 0, max(ylim), min(ylim))
47 :     }
48 : felix 161 stopifnot(is.numeric(origin))
49 : felix 148 ## need to split up the series into chunks without any missing values
50 :     ## (because NAs split the polygon)
51 :     xy <- data.frame(x = x, y = y)
52 : felix 167 ## order by ordinate values
53 :     ord <- if (horizontal) order(xy$y) else order(xy$x)
54 :     xy <- xy[ord,]
55 :     ok <- complete.cases(xy)
56 : felix 148 runs <- rle(ok)
57 :     ## assign unique values to each chunk, and NAs between (dropped by 'split')
58 :     runs$values[runs$values == TRUE] <- seq_len(sum(runs$values))
59 :     runs$values[runs$values == FALSE] <- NA
60 :     ## expand into long format
61 :     chunks <- inverse.rle(runs)
62 :     lapply(split(xy, chunks), function(xyi, ...) {
63 :     x <- xyi$x
64 :     y <- xyi$y
65 :     ## drop ends of series to the origin; the polygon will be joined up at that level
66 : felix 167 if (horizontal == TRUE) {
67 :     ## non-default case
68 :     yy <- c(head(y,1), y, tail(y,1))
69 :     xx <- c(origin, x, origin)
70 :     } else {
71 :     ## default case
72 :     xx <- c(head(x,1), x, tail(x,1))
73 :     yy <- c(origin, y, origin)
74 :     }
75 : felix 148 ## we need to catch the 'fill' argument from panel.superpose, otherwise over-rides 'col'
76 : felix 179 panel.polygon(xx, yy, alpha = alpha, col = col, border = border, lty = lty, lwd = lwd, ...)
77 : felix 148 }, ...)
78 :     }
79 :     }
80 :    
81 :     panel.xyarea.ts <- function(x, y = x, ...)
82 :     {
83 :     panel.xyarea(as.vector(time(x)), y, ...)
84 :     }
85 :    
86 : deepayan 194 panel.xyarea.zoo <- function(x, y = x, ...)
87 : felix 148 {
88 : deepayan 194 panel.xyarea(zoo::index(x), zoo::coredata(y), ...)
89 : felix 148 }
90 :    
91 :     ## A slightly modified copy of panel.qqmath
92 :     panel.qqmath.xyarea <-
93 :     function(x, y = NULL,
94 :     f.value = NULL,
95 :     distribution = qnorm,
96 :     qtype = 7,
97 :     groups = NULL, ...,
98 :     tails.n = 0)
99 :     {
100 :     x <- as.numeric(x)
101 :     distribution <-
102 :     if (is.function(distribution)) distribution
103 :     else if (is.character(distribution)) get(distribution)
104 :     else eval(distribution)
105 :     nobs <- sum(!is.na(x))
106 :     if (!is.null(groups))
107 :     panel.xyarea(x, y = NULL,
108 :     f.value = f.value,
109 :     distribution = distribution,
110 :     qtype = qtype,
111 :     groups = groups,
112 :     panel.groups = panel.qqmath.xyarea,
113 :     ...,
114 :     tails.n = tails.n)
115 :     else if (nobs)
116 :     {
117 :     if (is.null(f.value)) # exact data instead of quantiles
118 :     {
119 :     panel.xyarea(x = distribution(ppoints(nobs)),
120 :     y = sort(x),
121 :     ...)
122 :     }
123 :     else
124 :     {
125 :     pp <- if (is.numeric(f.value)) f.value else f.value(nobs)
126 :     if (tails.n > 0)
127 :     {
128 :     ## use exact data for tails of distribution
129 :     tails.n <- min(tails.n, nobs %/% 2)
130 :     ppd <- ppoints(nobs)
131 :     ## omit probabilities within the exact tails
132 :     pp <- pp[(pp > ppd[tails.n] &
133 :     pp < ppd[nobs + 1 - tails.n])]
134 :     ## add on probs corresponding to exact tails
135 :     pp <- c(head(ppd, tails.n), pp, tail(ppd, tails.n))
136 :     ## must use a quantile type that recovers exact values:
137 :     qtype <- 1
138 :     }
139 :     xx <- distribution(pp)
140 :     yy <- quantile(x, pp,
141 :     names = FALSE,
142 :     type = qtype,
143 :     na.rm = TRUE)
144 :     panel.xyarea(x = xx, y = yy, ...)
145 :     }
146 :     }
147 :     }

root@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