SCM

SCM Repository

[latticeextra] Annotation of /pkg/R/horizonplot.R
ViewVC logotype

Annotation of /pkg/R/horizonplot.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 164 - (view) (download)

1 : felix 148 ##
2 :     ## Copyright (c) 2010 Felix Andrews <felix@nfrac.org>
3 :     ## GPL version 2 or newer
4 :    
5 :     horizonplot <- function(x, data, ...)
6 :     UseMethod("horizonplot")
7 :    
8 :     horizonplot.default <-
9 :     function(x, data = NULL, ...,
10 : felix 164 horizonscale = NA,
11 : felix 161 origin = function(y) na.omit(y)[1],
12 :     colorkey = FALSE, legend = NULL,
13 : felix 148 panel = panel.horizonplot,
14 :     prepanel = prepanel.horizonplot,
15 : felix 161 col.regions = c("#B41414","#E03231","#F7A99C","#9FC8DC","#468CC8","#0165B3"),
16 : felix 148 strip = FALSE, strip.left = TRUE,
17 :     par.strip.text = list(cex = 0.6),
18 : felix 161 colorkey.digits = 3,
19 : felix 148 #layout = c(1, NA), ## TODO pending new lattice release
20 :     groups = NULL,
21 :     default.scales =
22 : felix 161 list(y = list(relation = "free", axs = "i",
23 : felix 148 draw = FALSE, tick.number = 2)))
24 :     {
25 :     if (!is.null(groups))
26 :     stop("'groups' does not work in this plot")
27 :     ans <- xyplot(x, data = data, ...,
28 : felix 161 origin = origin, horizonscale = horizonscale,
29 : felix 148 panel = panel, prepanel = prepanel,
30 : felix 161 col.regions = col.regions,
31 : felix 148 strip = strip, strip.left = strip.left,
32 :     par.strip.text = par.strip.text,
33 :     #layout = layout,
34 :     default.scales = default.scales)
35 :     ans$call <- match.call()
36 : felix 161 ## add colorkey
37 :     if (isTRUE(colorkey)) {
38 :     colorkey <- list()
39 :     }
40 :     if (is.list(colorkey)) {
41 :     if (ans$y.scales$relation == "same") {
42 :     origin <- ans$y.limits[1]
43 :     horizonscale <- diff(ans$y.limits)
44 :     }
45 :     if (is.na(horizonscale)) {
46 :     labels <- expression(
47 :     - 3 * Delta[i], - 2 * Delta[i], - 1 * Delta[i], 0,
48 :     + 1 * Delta[i], + 2 * Delta[i], + 3 * Delta[i], 0)
49 :     if (is.numeric(origin)) {
50 :     labels[4] <- origin
51 :     } else {
52 :     labels[4] <- "origin"
53 :     }
54 :     } else {
55 :     if (is.numeric(origin)) {
56 :     labels <- round(origin + (-3:3) * horizonscale, colorkey.digits)
57 :     } else {
58 :     labels <- paste(ifelse(-3:3>=0,"+","-"),
59 :     round(abs(-3:3) * horizonscale, colorkey.digits))
60 :     labels[4] <- "origin"
61 :     }
62 :     }
63 :     ii <- round((0:5 / 5) * (length(col.regions)-1)) + 1
64 :     colorkey <-
65 :     modifyList(list(col = col.regions[ii], at = -3:3,
66 :     labels = list(labels = labels, at = -3:3)),
67 :     colorkey)
68 :     space <- colorkey$space
69 :     if (is.null(space)) space <- "right"
70 :     if (is.null(legend)) legend <- list()
71 :     legend[[space]] <- list(fun = "draw.colorkey",
72 :     args = list(colorkey))
73 :     ans <- update(ans, legend = legend)
74 :     }
75 : felix 148 ans
76 :     }
77 :    
78 :    
79 :     panel.horizonplot <-
80 : felix 161 function(x, y, ..., border = NA,
81 :     col.regions = c("#B41414","#E03231","#F7A99C","#9FC8DC","#468CC8","#0165B3"),
82 :     origin) ## catch origin, don't pass to panel.xyarea!
83 : felix 148 {
84 :     regions <- trellis.par.get("regions")
85 :     origin <- current.panel.limits()$y[1]
86 :     scale <- diff(current.panel.limits()$y)
87 :     ## ordered for drawing, from least extreme to most extreme
88 : felix 161 sections <- c(0, -1, 1, -2, 2, -3) ## these are the lower bounds
89 :     ii <- round(((sections + 3) / 5) * (length(col.regions)-1)) + 1
90 : felix 148 col <- col.regions[ii]
91 :     for (i in seq_along(sections)) {
92 :     section <- sections[i]
93 :     yi <- y
94 :     if (section < 0) {
95 :     yi <- origin + origin - y
96 :     section <- abs(section) - 1
97 :     }
98 :     baseline <- origin + section * scale
99 :     if (all(yi <= baseline, na.rm = TRUE))
100 :     next
101 :     yi <- yi - baseline
102 :     yi <- origin + pmax(pmin(yi, scale), 0)
103 :     panel.xyarea(x, yi, border = border, col = col[i], ...)
104 :     }
105 :     }
106 :    
107 :     prepanel.horizonplot <-
108 : felix 164 function(x, y, ..., horizonscale = NA,
109 :     origin = function(y) na.omit(y)[1])
110 : felix 148 {
111 :     if (is.function(origin))
112 :     origin <- origin(y)
113 :     ans <- prepanel.default.xyplot(x, y, ...)
114 : felix 161 if (is.na(horizonscale))
115 :     horizonscale <- max(abs(ans$ylim - origin)) / 3
116 :     ans$ylim <- origin + c(0, horizonscale)
117 : felix 148 ans
118 :     }

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