SCM

SCM Repository

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

Annotation of /pkg/R/utilities.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 188 - (view) (download)

1 : deepayan 2
2 :     ## update elements of a list recursively.
3 :    
4 :     updateList <-
5 :     function (x, val)
6 :     {
7 :     if (is.null(x))
8 :     x <- list()
9 :     modifyList(x, val)
10 :     }
11 :    
12 :    
13 :     ## common operations that only make sense in certain contexts
14 :    
15 :    
16 :     useOuterStrips <-
17 :     function(x,
18 :     strip = strip.default,
19 :     strip.left = strip.custom(horizontal = FALSE),
20 :     strip.lines = 1,
21 :     strip.left.lines = strip.lines)
22 :     {
23 :     dimx <- dim(x)
24 :     stopifnot(inherits(x, "trellis"))
25 :     stopifnot(length(dimx) == 2)
26 : deepayan 188 as.table <- x$as.table
27 :    
28 : deepayan 2 opar <- if (is.null(x$par.settings)) list() else x$par.settings
29 :     par.settings <-
30 :     modifyList(opar,
31 :     list(layout.heights =
32 : deepayan 188 if (as.table) list(strip = c(strip.lines, rep(0, dimx[2]-1)))
33 : deepayan 47 else list(strip = c(rep(0, dimx[2]-1), strip.lines)),
34 : deepayan 2 layout.widths =
35 :     list(strip.left = c(strip.left.lines, rep(0, dimx[1]-1)))))
36 :     if (is.character(strip))
37 :     strip <- get(strip)
38 :     if (is.logical(strip) && strip)
39 :     strip <- strip.default
40 :     new.strip <-
41 :     if (is.function(strip))
42 :     {
43 :     function(which.given, which.panel, var.name, ...) {
44 : deepayan 188 row.to.keep <- if (as.table) 1 else nrow(trellis.currentLayout())
45 :     if (which.given == 1 && current.row() == row.to.keep)
46 : deepayan 2 strip(which.given = 1,
47 :     which.panel = which.panel[1],
48 :     var.name = var.name[1],
49 :     ...)
50 :     }
51 :     }
52 : deepayan 188 else strip # This could reasonable happen only if strip == FALSE
53 : deepayan 2 if (is.character(strip.left))
54 :     strip.left <- get(strip.left)
55 :     if (is.logical(strip.left) && strip.left)
56 :     strip.left <- strip.custom(horizontal = FALSE)
57 :     new.strip.left <-
58 :     if (is.function(strip.left))
59 :     {
60 :     function(which.given, which.panel, var.name, ...) {
61 : deepayan 188 if (which.given == 2 && current.column() == 1)
62 : deepayan 2 strip.left(which.given = 1,
63 :     which.panel = which.panel[2],
64 :     var.name = var.name[2],
65 :     ...)
66 :     }
67 :     }
68 :     else strip.left
69 :     update(x,
70 :     par.settings = par.settings,
71 :     strip = new.strip,
72 :     strip.left = new.strip.left,
73 :     par.strip.text = list(lines = 0.5),
74 :     layout = dimx)
75 :     }
76 :    
77 :    
78 :    
79 :    
80 :     resizePanels <-
81 :     function(x, h = 1, w = 1)
82 :     {
83 :     if (!missing(x))
84 :     return(update(x,
85 :     par.settings =
86 :     list(layout.heights = list(panel = h),
87 :     layout.widths = list(panel = w))))
88 :    
89 :     cl <- trellis.currentLayout()
90 :     if (all(dim(cl) > 1))
91 :     stop("layout must have single column or single row.")
92 :     if (all(dim(cl) == 1))
93 :     {
94 :     message("Nothing to be done.")
95 :     return()
96 :     }
97 :     if (any(cl == 0)) stop("missing panels not allowed")
98 :     if (dim(cl)[2] == 1) ## single column
99 :     {
100 :     pos <- seq(length = dim(cl)[1])
101 :     heights <-
102 :     sapply(pos,
103 :     function(i) {
104 :     trellis.focus("panel", 1, i, highlight = FALSE)
105 :     ylim <- current.panel.limits()$ylim
106 :     trellis.unfocus()
107 :     diff(range(ylim))
108 :     })
109 :     return(trellis.last.object(par.settings =
110 :     list(layout.heights = list(panel = heights))))
111 :     }
112 :     else if (dim(cl)[1] == 1) ## single row
113 :     {
114 :     pos <- seq(length = dim(cl)[2])
115 :     widths <-
116 :     sapply(pos,
117 :     function(i) {
118 :     trellis.focus("panel", i, 1, highlight = FALSE)
119 :     xlim <- current.panel.limits()$xlim
120 :     trellis.unfocus()
121 :     diff(range(xlim))
122 :     })
123 :     return(trellis.last.object(par.settings =
124 :     list(layout.widths = list(panel = widths))))
125 :     }
126 :     print(dim(cl))
127 :     stop("shouldn't come here")
128 :     }
129 :    
130 :    
131 :    
132 :    
133 :     ## utility functions to extract components of a formula. Don't work
134 :     ## reliably with unusual symbols
135 :    
136 :     .responseName <- function(formula)
137 :     {
138 :     if (length(formula) == 3) as.character(formula[2])
139 :     else stop("invalid formula")
140 :     }
141 :    
142 :     .covariateName <- function(formula)
143 :     {
144 :     RHS <-
145 :     if (length(formula) == 3) as.character(formula[3])
146 :     else if (length(formula) == 2) as.character(formula[2])
147 :     else stop("invalid formula")
148 :     RHS <- strsplit(RHS, " | ", fixed = TRUE)[[1]]
149 :     RHS[1]
150 :     }
151 :    
152 :     .groupsName <- function(formula)
153 :     {
154 :     RHS <-
155 :     if (length(formula) == 3) as.character(formula[3])
156 :     else if (length(formula) == 2) as.character(formula[2])
157 :     else stop("invalid formula")
158 :     RHS <- strsplit(RHS, " | ", fixed = TRUE)[[1]]
159 :     RHS[2]
160 :     }
161 :    
162 :    

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge