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