1################################################################ 2### strucplot - generic plot framework for mosaic-like layouts 3### 2 core functions are provided: struc_mosaic and struc_assoc 4################################################################ 5 6strucplot <- function(## main parameters 7 x, 8 residuals = NULL, 9 expected = NULL, 10 condvars = NULL, 11 shade = NULL, 12 type = c("observed", "expected"), 13 residuals_type = NULL, 14 df = NULL, 15 16 ## layout 17 split_vertical = NULL, 18 spacing = spacing_equal, 19 spacing_args = list(), 20 gp = NULL, 21 gp_args = list(), 22 labeling = labeling_border, 23 labeling_args = list(), 24 core = struc_mosaic, 25 core_args = list(), 26 legend = NULL, 27 legend_args = list(), 28 29 main = NULL, 30 sub = NULL, 31 margins = unit(3, "lines"), 32 title_margins = NULL, 33 legend_width = NULL, 34 35 ## control parameters 36 main_gp = gpar(fontsize = 20), 37 sub_gp = gpar(fontsize = 15), 38 newpage = TRUE, 39 pop = TRUE, 40 return_grob = FALSE, 41 keep_aspect_ratio = NULL, 42 prefix = "", 43 ... 44 ) { 45 ## default behaviour of shade 46 if (is.null(shade)) shade <- !is.null(gp) || !is.null(expected) 47 48 type <- match.arg(type) 49 if (is.null(residuals)) { 50 residuals_type <- if (is.null(residuals_type)) 51 "pearson" 52 else 53 match.arg(tolower(residuals_type), 54 c("pearson", "deviance", "ft")) 55 } else { 56 if (is.null(residuals_type)) 57 residuals_type <- "" 58 } 59 60 ## convert structable object 61 if (is.structable(x)) { 62 if (is.null(split_vertical)) 63 split_vertical <- attr(x, "split_vertical") 64 x <- as.table(x) 65 } 66 if (is.null(split_vertical)) 67 split_vertical <- FALSE 68 69 ## table characteristics 70 d <- dim(x) 71 dl <- length(d) 72 dn <- dimnames(x) 73 if (is.null(dn)) 74 dn <- dimnames(x) <- lapply(d, seq) 75 dnn <- names(dimnames(x)) 76 if (is.null(dnn)) 77 dnn <- names(dn) <- names(dimnames(x)) <- LETTERS[1:dl] 78 79 ## replace NAs by 0 80 if (any(nas <- is.na(x))) x[nas] <- 0 81 82 ## model fitting: 83 ## calculate df and expected if needed 84 ## (used for inference in some shading (generating) functions). 85 ## note: will *not* be calculated if residuals are given 86 if ((is.null(expected) && is.null(residuals)) || 87 !is.numeric(expected)) { 88 if (!is.null(df)) 89 warning("Using calculated degrees of freedom.") 90 if (inherits(expected, "formula")) { 91 fm <- loglm(expected, x, fitted = TRUE) 92 expected <- fitted(fm) 93 df <- fm$df 94 } else { 95 if (is.null(expected)) 96 expected <- if (is.null(condvars)) 97 as.list(1:dl) 98 else 99 lapply((condvars + 1):dl, c, seq(condvars)) 100 101 fm <- loglin(x, expected, fit = TRUE, print = FALSE) 102 expected <- fm$fit 103 df <- fm$df 104 } 105 } 106 107 ## compute residuals 108 if (is.null(residuals)) 109 residuals <- switch(residuals_type, 110 pearson = (x - expected) / sqrt(ifelse(expected > 0, expected, 1)), 111 deviance = { 112 tmp <- 2 * (x * log(ifelse(x == 0, 1, x / ifelse(expected > 0, expected, 1))) - (x - expected)) 113 tmp <- sqrt(pmax(tmp, 0)) 114 ifelse(x > expected, tmp, -tmp) 115 }, 116 ft = sqrt(x) + sqrt(x + 1) - sqrt(4 * expected + 1) 117 ) 118 ## replace NAs by 0 119 if (any(nas <- is.na(residuals))) residuals[nas] <- 0 120 121 ## splitting 122 if (length(split_vertical) == 1) 123 split_vertical <- rep(c(split_vertical, !split_vertical), length.out = dl) 124 125 if (is.null(keep_aspect_ratio)) 126 keep_aspect_ratio <- dl < 3 127 128 ## spacing 129 if (is.function(spacing)) { 130 if (inherits(spacing, "grapcon_generator")) 131 spacing <- do.call("spacing", spacing_args) 132 spacing <- spacing(d, condvars) 133 } 134 135 ## gp (color, fill, lty, etc.) argument 136 if (shade) { 137 if (is.null(gp)) gp <- shading_hcl 138 if (is.function(gp)) { 139 if (is.null(legend) || (is.logical(legend) && legend)) 140 legend <- legend_resbased 141 gpfun <- if (inherits(gp, "grapcon_generator")) 142 do.call("gp", c(list(x, residuals, expected, df), as.list(gp_args))) else gp 143 gp <- gpfun(residuals) 144 } else if (!is.null(legend) && !(is.logical(legend) && !legend)) 145 stop("gp argument must be a shading function for drawing a legend") 146 } else { 147 if(!is.null(gp)) { 148 warning("gp parameter ignored since shade = FALSE") 149 gp <- NULL 150 } 151 } 152 153 ## choose gray when no shading is used 154 if (is.null(gp)) gp <- gpar(fill = grey(0.8)) 155 156 ## recycle gpar values in the *first* dimension 157 size <- prod(d) 158 FUN <- function(par) { 159 if (is.structable(par)) 160 par <- as.table(par) 161 if (length(par) < size || is.null(dim(par))) 162 array(par, dim = d) 163 else 164 par 165 } 166 gp <- structure(lapply(gp, FUN), class = "gpar") 167 168 ## set up page 169 if (newpage) 170 grid.newpage() 171 if (keep_aspect_ratio) 172 pushViewport(viewport(width = 1, height = 1, default.units = "snpc")) 173 174 pushViewport(vcdViewport(mar = margins, 175 oma = title_margins, 176 legend = shade && !(is.null(legend) || is.logical(legend) && !legend), 177 main = !is.null(main), sub = !is.null(sub), 178 keep_aspect_ratio = keep_aspect_ratio, 179 legend_width = legend_width, 180 prefix = prefix)) 181 182 ## legend 183 if (inherits(legend, "grapcon_generator")) 184 legend <- do.call("legend", legend_args) 185 if (shade && !is.null(legend) && !(is.logical(legend) && !legend)) { 186 seekViewport(paste(prefix, "legend", sep = "")) 187 residuals_type <- switch(residuals_type, 188 deviance = "deviance\nresiduals:", 189 ft = "Freeman-Tukey\nresiduals:", 190 pearson = "Pearson\nresiduals:", 191 residuals_type) 192 legend(residuals, gpfun, residuals_type) 193 } 194 195 ## titles 196 if (!is.null(main)) { 197 seekViewport(paste(prefix, "main", sep = "")) 198 if (is.logical(main) && main) 199 main <- deparse(substitute(x)) 200 grid.text(main, gp = main_gp) 201 } 202 203 if (!is.null(sub)) { 204 seekViewport(paste(prefix, "sub", sep = "")) 205 if (is.logical(sub) && sub && is.null(main)) 206 sub <- deparse(substitute(x)) 207 grid.text(sub, gp = sub_gp) 208 } 209 210 ## make plot 211 seekViewport(paste(prefix, "plot", sep = "")) 212 213 if (inherits(core, "grapcon_generator")) 214 core <- do.call("core", core_args) 215 core(residuals = residuals, 216 observed = if (type == "observed") x else expected, 217 expected = if (type == "observed") expected else x, 218 spacing = spacing, 219 gp = gp, 220 split_vertical = split_vertical, 221 prefix = prefix) 222 223 upViewport(1) 224 225 ## labels 226 if (is.logical(labeling)) 227 labeling <- if (labeling) labeling_border else NULL 228 if (!is.null(labeling)) { 229 if (inherits(labeling, "grapcon_generator")) 230 labeling <- do.call("labeling", c(labeling_args, list(...))) 231 labeling(dn, split_vertical, condvars, prefix) 232 } 233 234 ## pop/move up viewport 235 236 seekViewport(paste(prefix, "base", sep = "")) 237 ## one more up if sandwich-mode 238 if (pop) 239 popViewport(1 + keep_aspect_ratio) 240 else 241 upViewport(1 + keep_aspect_ratio) 242 243 ## return visualized table 244 if (return_grob) 245 invisible(structure(structable(if (type == "observed") x else expected, 246 split_vertical = split_vertical), 247 grob = grid.grab() 248 ) 249 ) 250 else 251 invisible(structable(if (type == "observed") x else expected, 252 split_vertical = split_vertical)) 253} 254 255vcdViewport <- function(mar = rep.int(2.5, 4), 256 legend_width = unit(5, "lines"), 257 oma = NULL, 258 legend = FALSE, main = FALSE, sub = FALSE, 259 keep_aspect_ratio = TRUE, 260 prefix = "") 261{ 262 ## process parameters 263 if (is.null(legend_width)) 264 legend_width <- unit(5 * legend, "lines") 265 if (!is.unit(legend_width)) 266 legend_width <- unit(legend_width, "lines") 267 268 if (legend && !main && !sub && keep_aspect_ratio) main <- sub <- TRUE 269 mar <- if (!is.unit(mar)) 270 unit(pexpand(mar, 4, rep.int(2.5, 4), c("top","right","bottom","left")), "lines") 271 else 272 rep(mar, length.out = 4) 273 if (is.null(oma)) { 274 space <- if (legend && keep_aspect_ratio) 275 legend_width + mar[2] + mar[4] - mar[1] - mar[3] 276 else unit(0, "lines") 277 oma <- if (main && sub) 278 max(unit(2, "lines"), 0.5 * space) 279 else if (main) 280 unit.c(max(unit(2, "lines"), space), unit(0, "lines")) 281 else if (sub) 282 unit.c(unit(0, "lines"), max(unit(2, "lines"), space)) 283 else 284 0.5 * space 285 } 286 oma <- if (!is.unit(oma)) 287 unit(pexpand(oma, 2, rep.int(2, 2), c("top","bottom")), "lines") 288 else 289 rep(oma, length.out = 2) 290 291 ## set up viewports 292 vpPlot <- vpStack(viewport(layout.pos.col = 2, layout.pos.row = 3), 293 viewport(width = 1, height = 1, name = paste(prefix, "plot", sep = ""), 294 default.units = if (keep_aspect_ratio) "snpc" else "npc")) 295 vpMarginBottom <- viewport(layout.pos.col = 2, layout.pos.row = 4, 296 name = paste(prefix, "margin_bottom", sep = "")) 297 vpMarginLeft <- viewport(layout.pos.col = 1, layout.pos.row = 3, 298 name = paste(prefix, "margin_left", sep = "")) 299 vpMarginTop <- viewport(layout.pos.col = 2, layout.pos.row = 2, 300 name = paste(prefix, "margin_top", sep = "")) 301 vpMarginRight <- viewport(layout.pos.col = 3, layout.pos.row = 3, 302 name = paste(prefix, "margin_right", sep = "")) 303 vpCornerTL <- viewport(layout.pos.col = 1, layout.pos.row = 2, 304 name = paste(prefix, "corner_top_left", sep = "")) 305 vpCornerTR <- viewport(layout.pos.col = 3, layout.pos.row = 2, 306 name = paste(prefix, "corner_top_right", sep = "")) 307 vpCornerBL <- viewport(layout.pos.col = 1, layout.pos.row = 4, 308 name = paste(prefix, "corner_bottom_left", sep = "")) 309 vpCornerBR <- viewport(layout.pos.col = 3, layout.pos.row = 4, 310 name = paste(prefix, "corner_bottom_right", sep = "")) 311 312 vpLegend <- viewport(layout.pos.col = 4, layout.pos.row = 3, 313 name = paste(prefix, "legend", sep = "")) 314 vpLegendTop <- viewport(layout.pos.col = 4, layout.pos.row = 2, 315 name = paste(prefix, "legend_top", sep = "")) 316 vpLegendSub <- viewport(layout.pos.col = 4, layout.pos.row = 4, 317 name = paste(prefix, "legend_sub", sep = "")) 318 vpBase <- viewport(layout = grid.layout(5, 4, 319 widths = unit.c(mar[4], unit(1, "null"), mar[2], legend_width), 320 heights = unit.c(oma[1], mar[1], unit(1, "null"), mar[3], oma[2])), 321 name = paste(prefix, "base", sep = "")) 322 vpMain <- viewport(layout.pos.col = 1:4, layout.pos.row = 1, 323 name = paste(prefix, "main", sep = "")) 324 vpSub <- viewport(layout.pos.col = 1:4, layout.pos.row = 5, 325 name = paste(prefix, "sub", sep = "")) 326 327 vpTree(vpBase, vpList(vpMain, vpMarginBottom, vpMarginLeft, vpMarginTop, 328 vpMarginRight, vpLegendTop, vpLegend, 329 vpLegendSub, vpCornerTL, vpCornerTR, 330 vpCornerBL, vpCornerBR, vpPlot, vpSub)) 331} 332 333