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