1###########################################################
2## mosaicplot
3
4mosaic <- function(x, ...)
5    UseMethod("mosaic")
6
7mosaic.formula <-
8    function(formula, data = NULL, highlighting = NULL,
9             ..., main = NULL, sub = NULL, subset = NULL, na.action = NULL)
10{
11    if (is.logical(main) && main)
12        main <- deparse(substitute(data))
13    else if (is.logical(sub) && sub)
14        sub <- deparse(substitute(data))
15
16    m <- match.call(expand.dots = FALSE)
17    edata <- eval(m$data, parent.frame())
18
19    fstr <- strsplit(paste(deparse(formula), collapse = ""), "~")
20    vars <- strsplit(strsplit(gsub(" ", "", fstr[[1]][2]), "\\|")[[1]], "\\+")
21    varnames <- vars[[1]]
22
23    condnames <- if (length(vars) > 1) vars[[2]] else NULL
24
25    dep <- gsub(" ", "", fstr[[1]][1])
26    if (is.null(highlighting) && (!dep %in% c("","Freq"))) {
27        if (all(varnames == ".")) {
28            varnames <- if (is.data.frame(data))
29                            colnames(data)
30                        else
31                            names(dimnames(as.table(data)))
32            varnames <- varnames[-which(varnames %in% dep)]
33        }
34
35        varnames <- c(varnames, dep)
36        highlighting <- length(varnames) + length(condnames)
37    }
38
39
40    if (inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) {
41        condind <- NULL
42        dat <- as.table(data)
43        if(all(varnames != ".")) {
44            ind <- match(varnames, names(dimnames(dat)))
45            if (any(is.na(ind)))
46                stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", deparse(substitute(data))))
47
48            if (!is.null(condnames)) {
49                condind <- match(condnames, names(dimnames(dat)))
50                if (any(is.na(condind)))
51                    stop(paste("Can't find", paste(condnames[is.na(condind)], collapse=" / "), "in", deparse(substitute(data))))
52                ind <- c(condind, ind)
53            }
54            dat <- margin.table(dat, ind)
55        }
56        mosaic.default(dat, main = main, sub = sub, highlighting = highlighting,
57                       condvars = if (is.null(condind)) NULL else match(condnames, names(dimnames(dat))), ...)
58    } else {
59        m <- m[c(1, match(c("formula", "data", "subset", "na.action"), names(m), 0))]
60        m[[1]] <- as.name("xtabs")
61        m$formula <-
62            formula(paste(if("Freq" %in% colnames(data)) "Freq",
63                          "~",
64                          paste(c(condnames, varnames), collapse = "+")))
65        tab <- eval(m, parent.frame())
66        mosaic.default(tab, main = main, sub = sub, highlighting = highlighting, ...)
67    }
68}
69
70mosaic.default <- function(x, condvars = NULL,
71                           split_vertical = NULL, direction = NULL,
72                           spacing = NULL, spacing_args = list(),
73                           gp = NULL, expected = NULL, shade = NULL,
74                           highlighting = NULL,
75                           highlighting_fill = rev(gray.colors(tail(dim(x), 1))),
76                           highlighting_direction = NULL,
77                           zero_size = 0.5,
78                           zero_split = FALSE,
79                           zero_shade = NULL,
80                           zero_gp = gpar(col = 0),
81                           panel = NULL,
82                           main = NULL, sub = NULL, ...) {
83    zero_shade <- !is.null(shade) && shade || !is.null(expected) || !is.null(gp)
84    if (!is.null(shade) && !shade) zero_shade = FALSE
85
86    if (is.logical(main) && main)
87        main <- deparse(substitute(x))
88    else if (is.logical(sub) && sub)
89        sub <- deparse(substitute(x))
90
91    if (is.structable(x)) {
92        if (is.null(direction) && is.null(split_vertical))
93            split_vertical <- attr(x, "split_vertical")
94        x <- as.table(x)
95    }
96    if (is.null(split_vertical))
97        split_vertical <- FALSE
98
99    d <- dim(x)
100    dl <- length(d)
101
102    ## splitting argument
103    if (!is.null(direction))
104        split_vertical <- direction == "v"
105    if (length(split_vertical) == 1)
106        split_vertical <- rep(c(split_vertical, !split_vertical), length.out = dl)
107    if (length(split_vertical) < dl)
108        split_vertical <- rep(split_vertical, length.out = dl)
109
110    ## highlighting
111    if (!is.null(highlighting)) {
112        if (is.character(highlighting))
113            highlighting <- match(highlighting, names(dimnames(x)))
114        if (length(highlighting) > 0) {
115            if (is.character(condvars))
116                condvars <- match(condvars, names(dimnames(x)))
117            perm <- if (length(condvars) > 0)
118                     c(condvars, seq(dl)[-c(condvars,highlighting)], highlighting)
119                 else
120                     c(seq(dl)[-highlighting], highlighting)
121            x <- aperm(x, perm)
122            d <- d[perm]
123            split_vertical <- split_vertical[perm]
124            if (is.null(spacing))
125                spacing <- spacing_highlighting
126            if (is.function(highlighting_fill))
127                highlighting_fill <- highlighting_fill(d[dl])
128            if (is.null(gp))
129                gp <- gpar(fill = aperm(array(highlighting_fill, dim = rev(d))))
130            if (!is.null(highlighting_direction)) {
131                split_vertical[dl] <- highlighting_direction %in% c("left", "right")
132                if (highlighting_direction %in% c("left", "top")) {
133                    ## ugly:
134                    tmp <- as.data.frame.table(x)
135                    tmp[,dl] <- factor(tmp[,dl], rev(levels(tmp[,dl])))
136                    x <- xtabs(Freq ~ ., data = tmp)
137                    gp <- gpar(fill = aperm(array(rev(highlighting_fill),
138                                                  dim = rev(d))))
139                }
140            }
141        }
142    } else if (!is.null(condvars)) { # Conditioning only
143        if (is.character(condvars))
144            condvars <- match(condvars, names(dimnames(x)))
145        if (length(condvars) > 0) {
146            perm <- c(condvars, seq(dl)[-condvars])
147            x <- aperm(x, perm)
148            split_vertical <- split_vertical[perm]
149        }
150        if (is.null(spacing))
151            spacing <- spacing_conditional
152    }
153
154    ## spacing argument
155    if (is.null(spacing))
156        spacing <- if (dl < 3) spacing_equal else spacing_increase
157
158    strucplot(x,
159              condvars = if (is.null(condvars)) NULL else length(condvars),
160              core = struc_mosaic(zero_size = zero_size, zero_split = zero_split,
161              zero_shade = zero_shade, zero_gp = zero_gp, panel = panel),
162              split_vertical = split_vertical,
163              spacing = spacing,
164              spacing_args = spacing_args,
165              gp = gp,
166              expected = expected,
167              shade = shade,
168              main = main,
169              sub = sub,
170              ...)
171}
172
173## old code: more elegant, but less performant
174##
175## struc_mosaic2 <- function(zero_size = 0.5, zero_split = FALSE,
176##                          zero_shade = TRUE, zero_gp = gpar(col = 0))
177##   function(residuals, observed, expected = NULL, spacing, gp, split_vertical, prefix = "") {
178##     dn <- dimnames(observed)
179##     dnn <- names(dn)
180##     dx <- dim(observed)
181##     dl <- length(dx)
182
183##     ## split workhorse
184##     zerostack <- character(0)
185##     split <- function(x, i, name, row, col, zero) {
186##       cotab <- co_table(x, 1)
187##       margin <- sapply(cotab, sum)
188##       v <- split_vertical[i]
189##       d <- dx[i]
190
191##       ## compute total cols/rows and build split layout
192##       dist <- unit.c(unit(margin, "null"), spacing[[i]])
193##       idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d]
194##       layout <- if (v)
195##         grid.layout(ncol = 2 * d - 1, widths = dist[idx])
196##       else
197##         grid.layout(nrow = 2 * d - 1, heights = dist[idx])
198##       vproot <- viewport(layout.pos.col = col, layout.pos.row = row,
199##                          layout = layout, name = remove_trailing_comma(name))
200
201##       ## next level: either create further splits, or final viewports
202##       name <- paste(name, dnn[i], "=", dn[[i]], ",", sep = "")
203##       row <- col <- rep.int(1, d)
204##       if (v) col <- 2 * 1:d - 1 else row <- 2 * 1:d - 1
205##       f <- if (i < dl)
206##         function(m) {
207##           co <- cotab[[m]]
208##           z <- mean(co) <= .Machine$double.eps
209##           if (z && !zero && !zero_split) zerostack <<- c(zerostack, name[m])
210##           split(co, i + 1, name[m], row[m], col[m], z && !zero_split)
211##         }
212##       else
213##         function(m) {
214##           if (cotab[[m]] <= .Machine$double.eps && !zero)
215##             zerostack <<- c(zerostack, name[m])
216##           viewport(layout.pos.col = col[m], layout.pos.row = row[m],
217##                    name = remove_trailing_comma(name[m]))
218##         }
219##       vpleaves <- structure(lapply(1:d, f), class = c("vpList", "viewport"))
220
221##       vpTree(vproot, vpleaves)
222##     }
223
224##     ## start spltting on top, creates viewport-tree
225##     pushViewport(split(observed + .Machine$double.eps,
226##                        i = 1, name = paste(prefix, "cell:", sep = ""),
227##                        row = 1, col = 1, zero = FALSE))
228
229##     ## draw rectangles
230##     mnames <-  apply(expand.grid(dn), 1,
231##                      function(i) paste(dnn, i, collapse=",", sep = "=")
232##                      )
233##     zeros <- observed <= .Machine$double.eps
234
235##     ## draw zero cell lines
236##     for (i in remove_trailing_comma(zerostack)) {
237##       seekViewport(i)
238##       grid.lines(x = 0.5)
239##       grid.lines(y = 0.5)
240##       if (!zero_shade && zero_size > 0) {
241##         grid.points(0.5, 0.5, pch = 19, size = unit(zero_size, "char"),
242##                     gp = zero_gp,
243##                     name = paste(prefix, "disc:", mnames[i], sep = ""))
244##         grid.points(0.5, 0.5, pch = 1, size = unit(zero_size, "char"),
245##                     name = paste(prefix, "circle:", mnames[i], sep = ""))
246##       }
247##     }
248
249##     # draw boxes
250##     for (i in seq_along(mnames)) {
251##       seekViewport(paste(prefix, "cell:", mnames[i], sep = ""))
252##       gpobj <- structure(lapply(gp, function(x) x[i]), class = "gpar")
253##       if (!zeros[i]) {
254##         grid.rect(gp = gpobj, name = paste(prefix, "rect:", mnames[i], sep = ""))
255##       } else {
256##         if (zero_shade && zero_size > 0) {
257##           grid.points(0.5, 0.5, pch = 19, size = unit(zero_size, "char"),
258##                       gp = gpar(col = gp$fill[i]),
259##                       name = paste(prefix, "disc:", mnames[i], sep = ""))
260##           grid.points(0.5, 0.5, pch = 1, size = unit(zero_size, "char"),
261##                       name = paste(prefix, "circle:", mnames[i], sep = ""))
262##         }
263##       }
264##     }
265##   }
266## class(struc_mosaic2) <- "grapcon_generator"
267
268struc_mosaic <- function(zero_size = 0.5, zero_split = FALSE,
269                         zero_shade = TRUE, zero_gp = gpar(col = 0),
270                         panel = NULL)
271    function(residuals, observed, expected = NULL,
272             spacing, gp, split_vertical, prefix = "") {
273        dn <- dimnames(observed)
274        dnn <- names(dn)
275        dx <- dim(observed)
276        dl <- length(dx)
277
278        zeros <- function(gp, name) {
279            grid.lines(x = 0.5)
280            grid.lines(y = 0.5)
281            if (zero_size > 0) {
282                grid.points(0.5, 0.5, pch = 19, size = unit(zero_size, "char"),
283                            gp = gp, name = paste(prefix, "disc:", name, sep = ""))
284                grid.points(0.5, 0.5, pch = 1, size = unit(zero_size, "char"),
285                            name = paste(prefix, "circle:", name, sep = ""))
286            }
287        }
288
289        ## split workhorse
290        zerostack <- character(0)
291        split <- function(x, i, name, row, col, zero, index) {
292            cotab <- co_table(x, 1)
293            margin <- sapply(cotab, sum)
294            margin[margin == 0] <- .Machine$double.eps
295                                        #      margin <- margin + .Machine$double.eps
296            v <- split_vertical[i]
297            d <- dx[i]
298
299            ## compute total cols/rows and build split layout
300            dist <- if (d > 1)
301                        unit.c(unit(margin, "null"), spacing[[i]])
302                    else
303                        unit(margin, "null")
304            idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d]
305            layout <- if (v)
306                          grid.layout(ncol = 2 * d - 1, widths = dist[idx])
307                      else
308                          grid.layout(nrow = 2 * d - 1, heights = dist[idx])
309            pushViewport(viewport(layout.pos.col = col, layout.pos.row = row,
310                                  layout = layout, name = paste(prefix, "cell:",
311                                                   remove_trailing_comma(name),
312                                                   sep = "")))
313
314            ## next level: either create further splits, or final viewports
315            row <- col <- rep.int(1, d)
316            if (v) col <- 2 * 1:d - 1 else row <- 2 * 1:d - 1
317            for (m in 1:d) {
318                nametmp <- paste(name, dnn[i], "=", dn[[i]][m], ",", sep = "")
319                if (i < dl) {
320                    co <- cotab[[m]]
321
322                    ## zeros
323                    z <- mean(co) <= .Machine$double.eps
324                    split(co, i + 1, nametmp, row[m], col[m],
325                          z && !zero_split, cbind(index, m))
326                    if (z && !zero && !zero_split && !zero_shade && (zero_size > 0))
327                        zeros(zero_gp, nametmp)
328                } else {
329                    pushViewport(viewport(layout.pos.col = col[m],
330                                          layout.pos.row = row[m],
331                                          name = paste(prefix, "cell:",
332                                          remove_trailing_comma(nametmp), sep = "")))
333
334                    ## zeros
335                    if (cotab[[m]] <= .Machine$double.eps && !zero) {
336                        zeros(if (!zero_shade) zero_gp else gpar(col = gp$fill[cbind(index,m)]), nametmp)
337                    } else {
338                        ## rectangles
339                        gpobj <- structure(lapply(gp, function(x) x[cbind(index, m)]),
340                                           class = "gpar")
341                        nam <- paste(prefix, "rect:",
342                                     remove_trailing_comma(nametmp), sep = "")
343                        if (!is.null(panel))
344                            panel(residuals, observed, expected, c(cbind(index, m)),
345                                  gpobj, nam)
346                        else
347                            grid.rect(gp = gpobj, name = nam)
348                    }
349                }
350                upViewport(1)
351            }
352        }
353
354        ## start splitting on top, creates viewport-tree
355        split(observed, i = 1, name = "", row = 1, col = 1,
356              zero = FALSE, index = cbind())
357    }
358class(struc_mosaic) <- "grapcon_generator"
359