|
1.4.2
by Dirk Eddelbuettel
Import upstream version 0.6-14 |
1 |
##
|
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 |
horizonscale = NA, |
|
11 |
origin = function(y) na.omit(y)[1], |
|
12 |
colorkey = FALSE, legend = NULL, |
|
13 |
panel = panel.horizonplot, |
|
14 |
prepanel = prepanel.horizonplot, |
|
15 |
col.regions = c("#B41414","#E03231","#F7A99C","#9FC8DC","#468CC8","#0165B3"), |
|
16 |
strip = FALSE, strip.left = TRUE, |
|
17 |
par.strip.text = list(cex = 0.6), |
|
18 |
colorkey.digits = 3, |
|
19 |
#layout = c(1, NA), ## TODO pending new lattice release
|
|
20 |
groups = NULL, |
|
21 |
default.scales = |
|
22 |
list(y = list(relation = "free", axs = "i", |
|
23 |
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 |
origin = origin, horizonscale = horizonscale, |
|
29 |
panel = panel, prepanel = prepanel, |
|
30 |
col.regions = col.regions, |
|
31 |
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 |
## 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 |
ans
|
|
76 |
}
|
|
77 |
||
78 |
||
79 |
panel.horizonplot <- |
|
80 |
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 |
{
|
|
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 |
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 |
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) |
|
|
1.4.4
by Dirk Eddelbuettel
Import upstream version 0.6-18 |
103 |
panel.xyarea(x, yi, border = border, col = col[i], col.line = col[i], ...) |
|
1.4.2
by Dirk Eddelbuettel
Import upstream version 0.6-14 |
104 |
}
|
105 |
}
|
|
106 |
||
107 |
prepanel.horizonplot <- |
|
108 |
function(x, y, ..., horizonscale = NA, |
|
109 |
origin = function(y) na.omit(y)[1]) |
|
110 |
{
|
|
111 |
if (is.function(origin)) |
|
112 |
origin <- origin(y) |
|
113 |
ans <- prepanel.default.xyplot(x, y, ...) |
|
114 |
if (is.na(horizonscale)) |
|
115 |
horizonscale <- max(abs(ans$ylim - origin)) / 3 |
|
116 |
ans$ylim <- origin + c(0, horizonscale) |
|
117 |
ans
|
|
118 |
}
|