SCM

SCM Repository

[latticeextra] Annotation of /pkg/R/scale.components.R
ViewVC logotype

Annotation of /pkg/R/scale.components.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 181 - (view) (download)

1 : felix 148
2 :    
3 :     ## adapted from the Lattice book by Deepayan Sarkar
4 :    
5 :     xscale.components.logpower <- function(lim, ...) {
6 :     ans <- xscale.components.default(lim, ...)
7 :     ans$bottom$labels$labels <- parse(text = ans$bottom$labels$labels)
8 :     ans
9 :     }
10 : deepayan 181
11 : felix 148 yscale.components.logpower <- function(lim, ...) {
12 :     ans <- yscale.components.default(lim, ...)
13 :     ans$left$labels$labels <- parse(text = ans$left$labels$labels)
14 :     ans
15 :     }
16 :    
17 :     xscale.components.fractions <- function(lim, logsc = FALSE, ...) {
18 : felix 163 ans <- xscale.components.default(lim, logsc = logsc, ...)
19 : felix 148 ## get 'at' in data coordinates
20 :     if (identical(logsc, TRUE)) logsc <- 10
21 :     if (identical(logsc, "e")) logsc <- exp(1)
22 :     at <- ans$bottom$labels$at
23 :     if (!identical(logsc, FALSE))
24 :     at <- logsc ^ at
25 :     ans$bottom$labels$labels <- MASS::fractions(at)
26 :     ans
27 :     }
28 :    
29 :     yscale.components.fractions <- function(lim, logsc = FALSE, ...) {
30 : felix 163 ans <- yscale.components.default(lim, logsc = logsc, ...)
31 : felix 148 ## get 'at' in data coordinates
32 :     if (identical(logsc, TRUE)) logsc <- 10
33 :     if (identical(logsc, "e")) logsc <- exp(1)
34 :     at <- ans$left$labels$at
35 :     if (!identical(logsc, FALSE))
36 :     at <- logsc ^ at
37 :     ans$left$labels$labels <- MASS::fractions(at)
38 :     ans
39 :     }
40 :    
41 : deepayan 181 ## compute nice log-ticks. This is a version from the Lattice book
42 :     ## that is not very sophisticated.
43 :    
44 :     logTicksOld <- function (lim, loc = c(1, 5)) {
45 : felix 148 ii <- floor(log10(range(lim))) + c(-1, 2)
46 :     main <- 10^(ii[1]:ii[2])
47 :     r <- as.numeric(outer(loc, main, "*"))
48 :     r[lim[1] <= r & r <= lim[2]]
49 :     }
50 :    
51 : deepayan 181 ## A more sophisticated version that uses the same algorithm used in
52 :     ## traditional graphics, via axisTicks() - new in R 2.14.0
53 :    
54 :     logTicks <- function (lim, loc = NULL) {
55 :     if (is.null(loc)) axisTicks(log10(lim), log=TRUE)
56 :     else logTicksOld(lim, loc)
57 :     }
58 :    
59 :     xscale.components.log <- function(lim, logsc = FALSE, at = NULL, loc = NULL, ...) {
60 : felix 163 ans <- xscale.components.default(lim = lim, logsc = logsc, at = at, ...)
61 :     if (is.null(at)) return(ans)
62 : felix 148 if (identical(logsc, FALSE)) return(ans)
63 :     logbase <- logsc
64 :     if (identical(logbase, TRUE)) logbase <- 10
65 :     if (identical(logbase, "e")) logbase <- exp(1)
66 : deepayan 181 tick.at <- logTicks(logbase^lim, loc = loc)
67 : felix 148 ans$bottom$ticks$at <- log(tick.at, logbase)
68 :     ans$bottom$labels$at <- log(tick.at, logbase)
69 :     ans$bottom$labels$labels <- as.character(tick.at)
70 :     ans
71 :     }
72 :    
73 : deepayan 181 yscale.components.log <- function(lim, logsc = FALSE, at = NULL, loc = NULL, ...) {
74 : felix 163 ans <- yscale.components.default(lim = lim, logsc = logsc, at = at, ...)
75 :     if (is.null(at)) return(ans)
76 : felix 148 if (identical(logsc, FALSE)) return(ans)
77 :     logbase <- logsc
78 :     if (identical(logbase, TRUE)) logbase <- 10
79 :     if (identical(logbase, "e")) logbase <- exp(1)
80 : deepayan 181 tick.at <- logTicks(logbase^lim, loc = loc)
81 : felix 148 ans$left$ticks$at <- log(tick.at, logbase)
82 :     ans$left$labels$at <- log(tick.at, logbase)
83 :     ans$left$labels$labels <- as.character(tick.at)
84 :     ans
85 :     }
86 :    
87 : felix 163 xscale.components.log10.3 <- function(lim, logsc = FALSE, at = NULL, ...) {
88 : deepayan 181 xscale.components.log(lim, logsc = logsc, at = at, loc = c(1, 3))
89 :     }
90 :    
91 :     yscale.components.log10.3 <- function(lim, logsc = FALSE, at = NULL, ...) {
92 :     yscale.components.log(lim, logsc = logsc, at = at, loc = c(1, 3))
93 :     }
94 :    
95 :    
96 :     # major + minor ticks for powers of 10
97 :    
98 :     xscale.components.log10ticks <- function(lim, logsc = FALSE, at = NULL, ...) {
99 : felix 163 ans <- xscale.components.default(lim = lim, logsc = logsc, at = at, ...)
100 :     if (is.null(at)) return(ans)
101 : felix 148 if (identical(logsc, FALSE)) return(ans)
102 :     logbase <- logsc
103 :     if (identical(logbase, TRUE)) logbase <- 10
104 :     if (identical(logbase, "e")) logbase <- exp(1)
105 : deepayan 181 tick.at <- logTicks(logbase^lim, loc = 1:9)
106 :     tick.at.major <- logTicks(logbase^lim, loc = 1)
107 :     major <- tick.at %in% tick.at.major
108 : felix 148 ans$bottom$ticks$at <- log(tick.at, logbase)
109 : deepayan 181 ans$bottom$ticks$tck <- ifelse(major, 1, 0.5)
110 : felix 148 ans$bottom$labels$at <- log(tick.at, logbase)
111 :     ans$bottom$labels$labels <- as.character(tick.at)
112 : deepayan 181 ans$bottom$labels$labels[!major] <- ""
113 :     ans$bottom$labels$check.overlap <- FALSE
114 :     ans
115 : felix 148 }
116 :    
117 : deepayan 181 yscale.components.log10ticks <- function(lim, logsc = FALSE, at = NULL, ...) {
118 : felix 163 ans <- yscale.components.default(lim = lim, logsc = logsc, at = at, ...)
119 :     if (is.null(at)) return(ans)
120 : felix 148 if (identical(logsc, FALSE)) return(ans)
121 :     logbase <- logsc
122 :     if (identical(logbase, TRUE)) logbase <- 10
123 :     if (identical(logbase, "e")) logbase <- exp(1)
124 : deepayan 181 tick.at <- logTicks(logbase^lim, loc = 1:9)
125 :     tick.at.major <- logTicks(logbase^lim, loc = 1)
126 :     major <- tick.at %in% tick.at.major
127 : felix 148 ans$left$ticks$at <- log(tick.at, logbase)
128 : deepayan 181 ans$left$ticks$tck <- ifelse(major, 1, 0.5)
129 : felix 148 ans$left$labels$at <- log(tick.at, logbase)
130 :     ans$left$labels$labels <- as.character(tick.at)
131 : deepayan 181 ans$left$labels$labels[!major] <- ""
132 :     ans$left$labels$check.overlap <- FALSE
133 :     ans
134 : felix 148 }
135 :    
136 : deepayan 181
137 : felix 148 ## major + minor ticks (e.g. for date/time axes):
138 :    
139 :     xscale.components.subticks <-
140 : felix 163 function(lim, ..., n = 5, n2 = n * 5, min.n2 = n + 5)
141 : felix 148 {
142 :     ans <- xscale.components.default(lim = lim, ..., n = n)
143 :     ans2 <- xscale.components.default(lim = lim, ..., n = n2, min.n = min.n2)
144 :     ticks <- ans$bottom$ticks$at
145 :     ticks2 <- ans2$bottom$ticks$at
146 :     ticks2 <- ticks2[!(ticks2 %in% ticks)]
147 :     ans$bottom$ticks$at <- c(ticks, ticks2)
148 : felix 158 ans$bottom$ticks$tck <- c(rep(1, length(ticks)),
149 :     rep(0.5, length(ticks2)))
150 : felix 148 ans$bottom$labels$at <- ans$bottom$ticks$at
151 :     ans$bottom$labels$labels <- c(ans$bottom$labels$labels,
152 : felix 163 rep(" ", length(ticks2)))
153 : felix 148 ans$bottom$labels$check.overlap <- FALSE
154 :     ans
155 :     }
156 :    
157 :     yscale.components.subticks <-
158 : felix 163 function(lim, ..., n = 5, n2 = n * 5, min.n2 = n + 5)
159 : felix 148 {
160 :     ans <- yscale.components.default(lim = lim, ..., n = n)
161 :     ans2 <- yscale.components.default(lim = lim, ..., n = n2, min.n = min.n2)
162 :     ticks <- ans$left$ticks$at
163 :     ticks2 <- ans2$left$ticks$at
164 :     ticks2 <- ticks2[!(ticks2 %in% ticks)]
165 :     ans$left$ticks$at <- c(ticks, ticks2)
166 : felix 158 ans$left$ticks$tck <- c(rep(1, length(ticks)),
167 :     rep(0.5, length(ticks2)))
168 : felix 148 ans$left$labels$at <- ans$left$ticks$at
169 :     ans$left$labels$labels <- c(ans$left$labels$labels,
170 : felix 163 rep(" ", length(ticks2)))
171 : felix 148 ans$left$labels$check.overlap <- FALSE
172 :     ans
173 :     }

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