SCM

SCM Repository

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

Annotation of /pkg/R/panel.lmlineq.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 148 - (view) (download)

1 : felix 148 ##
2 :     ## Copyright (c) 2009 Felix Andrews <felix@nfrac.org>
3 :     ## GPL version 2 or newer
4 :    
5 :     panel.ablineq <-
6 :     function(a = NULL, b = 0,
7 :     h = NULL, v = NULL,
8 :     reg = NULL, coef = NULL,
9 :     pos = if (rotate) 1 else NULL,
10 :     offset = 0.5, adj = NULL,
11 :     at = 0.5,
12 :     x = NULL, y = NULL,
13 :     rotate = FALSE, srt = 0,
14 :     label = NULL,
15 :     varNames = alist(y = y, x = x),
16 :     varStyle = "italic",
17 :     fontfamily = "serif",
18 :     digits = 3,
19 :     r.squared = FALSE, sep = ", ", sep.end = "",
20 :     col, col.text = add.text$col,
21 :     col.line = add.line$col,
22 :     ..., reference = FALSE)
23 :     {
24 :     if (!is.null(label)) varStyle <- NULL
25 :     ## work out colours for text and line
26 :     add.text <- trellis.par.get("add.text")
27 :     add.line <- if (reference)
28 :     trellis.par.get("reference.line")
29 :     else trellis.par.get("add.line")
30 :     if (!missing(col) && missing(col.line))
31 :     col.line <- col
32 :     if (!missing(col) && missing(col.text))
33 :     col.text <- col
34 :     ## draw the line
35 :     panel.abline(a = a, b = b, h = h, v = v, reg = reg, coef = coef,
36 :     col = col.line, ..., reference = reference)
37 :     ## extract r.squared from model object if any
38 :     if (!is.null(reg)) {
39 :     a <- reg
40 :     }
41 :     if (isTRUE(r.squared)) {
42 :     if (is.object(a) || is.list(a)) {
43 :     r.squared <- round(summary(a)$r.squared, digits)
44 :     } else {
45 :     warning("r.squared = TRUE requires a model object")
46 :     }
47 :     }
48 :     ## work out equation coefficients
49 :     ## the following copied from lattice::panel.abline
50 :     if (is.object(a) || is.list(a)) {
51 :     p <- length(coefa <- as.vector(coef(a)))
52 :     if (p > 2)
53 :     warning("only using the first two of ", p, "regression coefficients")
54 :     islm <- inherits(a, "lm")
55 :     noInt <- if (islm)
56 :     !as.logical(attr(stats::terms(a), "intercept"))
57 :     else p == 1
58 :     if (noInt) {
59 :     a <- 0
60 :     b <- coefa[1]
61 :     }
62 :     else {
63 :     a <- coefa[1]
64 :     b <- if (p >= 2)
65 :     coefa[2]
66 :     else 0
67 :     }
68 :     }
69 :     if (!is.null(coef)) {
70 :     if (!is.null(a))
71 :     warning("'a' and 'b' are overridden by 'coef'")
72 :     a <- coef[1]
73 :     b <- coef[2]
74 :     }
75 :     if (length(h <- as.numeric(h)) > 0) {
76 :     if (!is.null(a))
77 :     warning("'a' and 'b' are overridden by 'h'")
78 :     a <- h[1]
79 :     b <- 0
80 :     }
81 :     if (length(a) > 1) {
82 :     b <- a[2]
83 :     a <- a[1]
84 :     }
85 :     ## construct the equation label
86 :     if (length(as.numeric(v)) > 0) {
87 :     ## vertical line (special case)
88 :     if (!is.null(a))
89 :     warning("'a' and 'b' are overridden by 'v'")
90 :     if (is.null(x))
91 :     x <- v[1]
92 :     if (is.null(y))
93 :     y <- convertY(unit(at, "npc"), "native", TRUE)
94 :     if (is.null(label)) {
95 :     v <- signif(v[1], digits)
96 :     varNames <- c(as.list(varNames), v = v)
97 :     label <- substitute(x == v, varNames)
98 :     }
99 :     } else {
100 :     ## normal a+bx line
101 :     if (is.null(x)) {
102 :     ## work out start and end x values of visible line
103 :     xlim <- current.panel.limits()$xlim
104 :     ylim <- current.panel.limits()$ylim
105 :     if (b == 0) {
106 :     xx <- xlim
107 :     } else {
108 :     xx <- range((ylim - a) / b)
109 :     xx <- pmin(max(xlim), xx)
110 :     xx <- pmax(min(xlim), xx)
111 :     }
112 :     ## x position as fractional distance along line
113 :     x <- min(xx) + at * abs(diff(xx))
114 :     }
115 :     if (is.null(y))
116 :     y <- a + b * x
117 :     if (is.null(label)) {
118 :     a <- round(a, digits)
119 :     b <- round(b, digits)
120 :     varNames <- c(as.list(varNames), a = a, b = b)
121 :     if (b == 0) {
122 :     label <- substitute(y == a, varNames)
123 :     } else if (a == 0) {
124 :     label <- substitute(y == b * x, varNames)
125 :     } else if (b > 0) {
126 :     label <- substitute(y == a + b * x, varNames)
127 :     } else {
128 :     varNames$b <- abs(b)
129 :     label <- substitute(y == a - b * x, varNames)
130 :     }
131 :     }
132 :     }
133 :     if (rotate) {
134 :     if (length(as.numeric(v)) > 0) {
135 :     srt <- 90
136 :     } else {
137 :     ## aspect ratio with respect to native coordinates
138 :     asp <- with(lapply(current.panel.limits(), diff), ylim / xlim)
139 :     ## aspect ratio of panel at *current* device size
140 :     asp.cm <- with(lapply(current.panel.limits("cm"), diff), ylim / xlim)
141 :     grad <- b * (asp.cm / asp)
142 :     srt <- 180 * atan(grad) / pi
143 :     }
144 :     }
145 :     if (is.numeric(r.squared)) {
146 :     ## add R^2 = ... to label
147 :     rsq.expr <- substitute(italic(R)^2 == z,
148 :     list(z = r.squared))
149 :     label <- call("paste", label, sep, rsq.expr, sep.end)
150 :     }
151 :     ## wrap 'varStyle' function (or multiple functions) around label expression
152 :     if (!is.null(varStyle)) {
153 :     while (length(varStyle) > 0) {
154 :     label <- call(varStyle[1], label)
155 :     varStyle <- varStyle[-1]
156 :     }
157 :     }
158 :     panel.text(x = x, y = y, labels = label,
159 :     pos = pos, offset = offset, adj = adj,
160 :     fontfamily = fontfamily, srt = srt,
161 :     col = col.text, ...)
162 :     }
163 :    
164 :     panel.lmlineq <-
165 :     function(x, y, ...)
166 :     {
167 :     if (length(x) > 1)
168 :     panel.ablineq(lm(as.numeric(y) ~ as.numeric(x)), ...)
169 :     }
170 :    

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