1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
#######################################
### doubledecker plot
doubledecker <- function(x, ...)
UseMethod("doubledecker")
doubledecker.formula <-
function(formula, data = NULL, ..., main = NULL)
{
if (is.logical(main) && main)
main <- deparse(substitute(data))
if (is.structable(data))
data <- as.table(data)
m <- match.call(expand.dots = FALSE)
edata <- eval(m$data, parent.frame())
fstr <- strsplit(paste(deparse(formula), collapse = ""), "~")
vars <- strsplit(strsplit(gsub(" ", "", fstr[[1]][2]), "\\|")[[1]], "\\+")
dep <- gsub(" ", "", fstr[[1]][1])
varnames <- vars[[1]]
if (dep == "")
stop("Need a dependent variable!")
varnames <- c(varnames, dep)
if(inherits(edata, "ftable")
|| inherits(edata, "table")
|| length(dim(edata)) > 2) {
dat <- as.table(data)
if(all(varnames != ".")) {
ind <- match(varnames, names(dimnames(dat)))
if (any(is.na(ind)))
stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", deparse(substitute(data))))
dat <- margin.table(dat, ind)
} else {
ind <- match(dep, names(dimnames(dat)))
if (is.na(ind))
stop(paste("Can't find", dep, "in", deparse(substitute(data))))
dat <- aperm(dat, c(seq_along(dim(dat))[-ind], ind))
}
doubledecker.default(dat, main = main, ...)
} else {
tab <- if ("Freq" %in% colnames(data))
xtabs(formula(paste("Freq~", varnames, collapse = "+")),
data = data)
else
xtabs(formula(paste("~", varnames, collapse = "+")),
data = data)
doubledecker.default(tab, main = main, ...)
}
}
doubledecker.default <- function(x,
depvar = length(dim(x)),
margins = c(1, 4, length(dim(x)) + 1, 1),
gp = gpar(fill = rev(gray.colors(tail(dim(x), 1)))),
labeling = labeling_doubledecker,
spacing = spacing_highlighting,
main = NULL,
keep_aspect_ratio = FALSE,
...) {
x <- as.table(x)
d <- dim(x)
l <- length(d)
if (is.character(depvar))
depvar <- match(depvar, names(dimnames(x)))
condvars <- (1:l)[-depvar]
x <- aperm(x, c(condvars, depvar))
strucplot(x,
core = struc_mosaic(zero_split = FALSE, zero_shade = FALSE),
condvars = l - 1,
spacing = spacing,
split_vertical = c(rep.int(TRUE, l - 1), FALSE),
gp = gp,
shade = TRUE,
labeling = labeling,
main = main,
margins = margins,
legend = NULL,
keep_aspect_ratio = keep_aspect_ratio,
...
)
}
|
