1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
prepanel.rootogram <-
function(x, y = table(x),
dfun = NULL,
transformation = sqrt,
hang = TRUE,
...)
{
plot.line <- trellis.par.get("plot.line")
stopifnot(is.function(dfun))
yy <- transformation(y / sum(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,
...)
{
plot.line <- trellis.par.get("plot.line")
ref.line <- trellis.par.get("reference.line")
stopifnot(is.function(dfun))
yy <- transformation(y / sum(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,
...)
panel.lines(xx, dd)
}
rootogram <-
function(x, ...)
UseMethod("rootogram")
rootogram.formula <-
function(x, data = parent.frame(),
ylab = expression(sqrt(P(X == x))),
prepanel = prepanel.rootogram,
panel = panel.rootogram,
...)
{
if (length(x) == 2) ## formula like ~ x
foo <-
densityplot(x, data,
prepanel = prepanel,
panel = panel,
ylab = ylab,
...)
else ## formula like y ~ x
foo <-
xyplot(x, data,
prepanel = prepanel,
panel = panel,
ylab = ylab,
...)
foo$call <- sys.call(sys.parent()); foo$call[[1]] <- quote(rootogram)
foo
}
|