SCM

SCM Repository

[latticeextra] Annotation of /pkg/R/marginal.plot.R
ViewVC logotype

Annotation of /pkg/R/marginal.plot.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 156 - (view) (download)

1 : felix 34 ##
2 :     ## Copyright (c) 2007 Felix Andrews <felix@nfrac.org>
3 :     ## GPL version 2 or newer
4 :    
5 :     is.categorical <- function (x)
6 :     {
7 :     is.factor(x) || is.shingle(x) || is.character(x) || is.logical(x)
8 :     }
9 :    
10 :     marginal.plot <-
11 :     function(x,
12 :     data = NULL,
13 :     groups = NULL,
14 :     reorder = !is.table(x),
15 :     plot.points = FALSE,
16 : felix 154 ref = TRUE, cut = 0,
17 : felix 156 origin = 0, #ylim = c(0, NA), this only supported in R >= 2.11
18 : felix 34 xlab = NULL, ylab = NULL,
19 :     type = c("p", if (is.null(groups)) "h"),
20 :     ...,
21 :     subset = TRUE,
22 :     as.table = TRUE,
23 :     subscripts = TRUE,
24 :     default.scales = list(
25 :     relation = "free",
26 :     abbreviate = TRUE, minlength = 5,
27 :     rot = 30, cex = 0.75, tick.number = 3,
28 :     y = list(draw = FALSE)),
29 : felix 41 layout = NULL,
30 : felix 34 lattice.options = list(
31 :     layout.heights = list(
32 :     axis.xlab.padding = list(x = 0),
33 :     xlab.key.padding = list(x = 0))))
34 :     {
35 :     if (is.table(data))
36 :     data <- as.data.frame(data)
37 :     ## assume first term of formula is the data object; ignore rest
38 :     if (inherits(x, "formula"))
39 :     x <- eval(x[[2]], data, environment(x))
40 :     ## x must be either a data.frame or a table
41 :     if (!is.data.frame(x) && !is.table(x))
42 :     x <- as.data.frame(x)
43 :     ## groups and subset are subject to non-standard evaluation:
44 :     groups <- eval(substitute(groups), data, parent.frame())
45 :     ## note unusual cases e.g.
46 :     ## evalq(marginal.plot(dat, subset = complete.cases(dat)), myEnv)
47 :     subset <- eval(substitute(subset), data, parent.frame())
48 :     ## apply subset
49 :     if ((length(subset) > 0) && !isTRUE(subset)) {
50 :     x <- x[subset,]
51 :     if (!is.null(groups))
52 :     groups <- groups[subset]
53 :     }
54 :     ## divide into categoricals and numerics
55 :     if (is.table(x)) {
56 :     iscat <- TRUE
57 :     } else {
58 :     iscat <- sapply(x, is.categorical)
59 :     }
60 :     ## reorder factor levels
61 :     if (reorder) {
62 :     if (is.table(x)) {
63 :     x <- reorderTableByFreq(x)
64 :     } else {
65 :     for (nm in names(x)[iscat]) {
66 :     val <- x[[nm]]
67 :     if (is.character(val))
68 :     x[[nm]] <- factor(val)
69 :     if (!is.ordered(val) &&
70 :     !is.shingle(val) &&
71 :     nlevels(val) > 1)
72 :     {
73 :     x[[nm]] <- reorder(val, val, function(z) -length(z))
74 :     }
75 :     }
76 :     }
77 :     }
78 :     if (any(iscat)) {
79 :     ## handle categorical variables
80 :     ## make a list of dotplot trellis objects
81 :     if (is.table(x)) {
82 :     margins <- seq(length = length(dim(x)))
83 :     names(margins) <- names(dimnames(x))
84 :     } else {
85 :     margins <- which(iscat)
86 :     names(margins) <- colnames(x)[iscat]
87 :     }
88 :     dotobjs <-
89 :     lapply(margins,
90 :     function(i)
91 :     {
92 :     if (is.table(x)) {
93 :     nm <- names(dimnames(x))[i]
94 :     nm <- deparse(as.symbol(nm), backtick = TRUE)
95 :     form <- paste("Freq ~", nm)
96 :     if (!is.null(groups))
97 :     form <- paste(form, "+ groups")
98 :     tab <- xtabs(as.formula(form), x)
99 :     } else {
100 :     if (!is.null(groups)) {
101 :     tab <- table(Value = x[[i]], groups = groups)
102 :     } else {
103 :     tab <- table(Value = x[[i]])
104 :     }
105 :     }
106 :     dotplot(tab, horizontal = FALSE,
107 :     groups = !is.null(groups),
108 :     subscripts = TRUE,
109 :     ...,
110 :     type = type,
111 : felix 156 origin = origin, #ylim = ylim,
112 : felix 34 as.table = as.table,
113 :     default.scales = default.scales,
114 :     lattice.options = lattice.options,
115 :     xlab = xlab, ylab = ylab)
116 :     })
117 :     ## merge the list of trellis objects into one
118 : felix 154 catobj <- do.call("c", c(dotobjs, merge.legends = FALSE))
119 : felix 41 catobj$layout <- layout
120 : felix 34 catobj$call <- match.call()
121 :     }
122 :     if (any(!iscat)) {
123 :     ## handle numeric variables
124 :     ## construct formula with all numeric variables
125 :     nms <- names(x)[!iscat]
126 :     symbolStr <- function(nm)
127 :     deparse(as.symbol(nm), backtick = TRUE)
128 :     nms <- sapply(nms, symbolStr)
129 :     numform <- paste("~", paste(nms, collapse = " + "))
130 :     numobj <-
131 :     densityplot(as.formula(numform), x, outer = TRUE,
132 :     subscripts = TRUE,
133 :     groups = groups,
134 :     ...,
135 : felix 40 plot.points = plot.points,
136 : felix 156 ref = ref, cut = cut, #ylim = ylim,
137 : felix 34 as.table = as.table,
138 :     default.scales = default.scales,
139 :     lattice.options = lattice.options,
140 :     xlab = xlab, ylab = ylab)
141 :     ## set strip name if only one panel
142 :     if (prod(dim(numobj)) == 1)
143 :     rownames(numobj) <- names(x)[!iscat]
144 :     numobj$call <- match.call()
145 : felix 41 numobj$layout <- layout
146 : felix 34 }
147 : felix 107 if (all(iscat)) {
148 :     obj <- catobj
149 :     } else if (all(!iscat)) {
150 :     obj <- numobj
151 :     } else {
152 :     ## if there are both categoricals and numerics,
153 :     ## merge the trellis objects; keep original var order
154 :     reIndex <- order(c(which(iscat), which(!iscat)))
155 : felix 154 obj <- update(c(catobj, numobj, merge.legends = FALSE),
156 : felix 107 index.cond = list(reIndex), layout = layout)
157 :     ## force strips when only one panel in each object
158 :     if (identical(obj$strip, FALSE))
159 :     obj$strip <- "strip.default"
160 :     }
161 :     obj$call <- sys.call(sys.parent())
162 : felix 34 obj
163 :     }
164 :    
165 :     reorderTableByFreq <- function(x)
166 :     {
167 :     stopifnot(is.table(x))
168 :     df <- as.data.frame(x)
169 :     i <- which(names(df) == "Freq")
170 :     df[-i] <- lapply(df[-i], reorder, - df$Freq)
171 :     xtabs(Freq ~ ., df)
172 :     }
173 :    

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge