Skip to content
This repository
Newer
Older
100644 169 lines (139 sloc) 4.832 kb
0ec7d09d »
2011-05-19 Un-document internal layout functions
1 # Layout panels in a 2d grid.
1244716e »
2014-02-24 Trim whitespace
2 #
0ec7d09d »
2011-05-19 Un-document internal layout functions
3 # @params data list of data frames, one for each layer
4 # @params rows variables that form the rows
5 # @params cols variables that form the columns
6 # @return a data frame with columns \code{PANEL}, \code{ROW} and \code{COL},
1244716e »
2014-02-24 Trim whitespace
7 # that match the facetting variable values up with their position in the
0ec7d09d »
2011-05-19 Un-document internal layout functions
8 # grid
aaa334d6 »
2012-04-20 Implement as.table for facet_grid.
9 layout_grid <- function(data, rows = NULL, cols = NULL, margins = NULL, drop = TRUE, as.table = TRUE) {
a4c85114 »
2011-05-18 Copy over all new files
10 if (length(rows) == 0 && length(cols) == 0) return(layout_null())
11 rows <- as.quoted(rows)
12 cols <- as.quoted(cols)
1244716e »
2014-02-24 Trim whitespace
13
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
14 base_rows <- layout_base(data, rows, drop = drop)
aaa334d6 »
2012-04-20 Implement as.table for facet_grid.
15 if (!as.table) {
16 rev_order <- function(x) factor(x, levels = rev(ulevels(x)))
17 base_rows[] <- lapply(base_rows, rev_order)
18 }
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
19 base_cols <- layout_base(data, cols, drop = drop)
04b2eefd »
2011-05-19 Display working with 2d grid
20 base <- df.grid(base_rows, base_cols)
1244716e »
2014-02-24 Trim whitespace
21
a4c85114 »
2011-05-18 Copy over all new files
22 # Add margins
9fb2a973 »
2011-05-18 Testing facetting.
23 base <- add_margins(base, list(names(rows), names(cols)), margins)
24 # Work around bug in reshape2
25 base <- unique(base)
a4c85114 »
2011-05-18 Copy over all new files
26
27 # Create panel info dataset
cb851822 »
2011-05-19 Fix grid layout bugs for nested layouts
28 panel <- id(base, drop = TRUE)
a4c85114 »
2011-05-18 Copy over all new files
29 panel <- factor(panel, levels = seq_len(attr(panel, "n")))
1244716e »
2014-02-24 Trim whitespace
30
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
31 rows <- if (is.null(names(rows))) 1L else id(base[names(rows)], drop = TRUE)
32 cols <- if (is.null(names(cols))) 1L else id(base[names(cols)], drop = TRUE)
1244716e »
2014-02-24 Trim whitespace
33
9fb2a973 »
2011-05-18 Testing facetting.
34 panels <- data.frame(PANEL = panel, ROW = rows, COL = cols, base)
9f146dbb »
2014-03-25 Add drop = FALSE to be safe
35 panels <- panels[order(panels$PANEL), , drop = FALSE]
687ba6ef »
2014-03-25 Avoid more non-standard evaluation
36 rownames(panels) <- NULL
37 panels
a4c85114 »
2011-05-18 Copy over all new files
38 }
39
0ec7d09d »
2011-05-19 Un-document internal layout functions
40 # Layout out panels in a 1d ribbon.
41 #
42 # @params drop should missing combinations be excluded from the plot?
43 # @keywords internal
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
44 layout_wrap <- function(data, vars = NULL, nrow = NULL, ncol = NULL, as.table = TRUE, drop = TRUE) {
a4c85114 »
2011-05-18 Copy over all new files
45 vars <- as.quoted(vars)
46 if (length(vars) == 0) return(layout_null())
47
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
48 base <- unrowname(layout_base(data, vars, drop = drop))
a4c85114 »
2011-05-18 Copy over all new files
49
284022e6 »
2011-05-22 Remove facet_wrap drop param, as it's not obvious what it should do
50 id <- id(base, drop = TRUE)
a4c85114 »
2011-05-18 Copy over all new files
51 n <- attr(id, "n")
1244716e »
2014-02-24 Trim whitespace
52
a4c85114 »
2011-05-18 Copy over all new files
53 dims <- wrap_dims(n, nrow, ncol)
3db9f8e4 »
2011-05-22 facet_wrap as.table working
54 layout <- data.frame(PANEL = factor(id, levels = seq_len(n)))
1244716e »
2014-02-24 Trim whitespace
55
3db9f8e4 »
2011-05-22 facet_wrap as.table working
56 if (as.table) {
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
57 layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L)
3db9f8e4 »
2011-05-22 facet_wrap as.table working
58 } else {
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
59 layout$ROW <- as.integer(dims[1] - (id - 1L) %/% dims[2])
3db9f8e4 »
2011-05-22 facet_wrap as.table working
60 }
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
61 layout$COL <- as.integer((id - 1L) %% dims[2] + 1L)
1244716e »
2014-02-24 Trim whitespace
62
9ba0ef14 »
2011-12-23 Fix panel ordering bug
63 panels <- cbind(layout, unrowname(base))
9f146dbb »
2014-03-25 Add drop = FALSE to be safe
64 panels <- panels[order(panels$PANEL), , drop = FALSE]
687ba6ef »
2014-03-25 Avoid more non-standard evaluation
65 rownames(panels) <- NULL
66 panels
a4c85114 »
2011-05-18 Copy over all new files
67 }
68
1244716e »
2014-02-24 Trim whitespace
69 layout_null <- function(data) {
a4c85114 »
2011-05-18 Copy over all new files
70 data.frame(PANEL = 1, ROW = 1, COL = 1)
71 }
72
0ec7d09d »
2011-05-19 Un-document internal layout functions
73 # Base layout function that generates all combinations of data needed for
74 # facetting
31df5ac1 »
2012-07-08 Correct order of facets when adding layers. Fixes #543
75 # The first data frame in the list should be the default data for the plot.
76 # Other data frames in the list are ones that are added to layers.
0ec7d09d »
2011-05-19 Un-document internal layout functions
77 #
78 # @params data list of data frames (one for each layer)
79 # @keywords internal
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
80 layout_base <- function(data, vars = NULL, drop = TRUE) {
04b2eefd »
2011-05-19 Display working with 2d grid
81 if (length(vars) == 0) return(data.frame())
a4c85114 »
2011-05-18 Copy over all new files
82
83 # For each layer, compute the facet values
84 values <- compact(llply(data, quoted_df, vars = vars))
85
86 # Form the base data frame which contains all combinations of facetting
87 # variables that appear in the data
88 has_all <- unlist(llply(values, length)) == length(vars)
89 if (!any(has_all)) {
90 stop("At least one layer must contain all variables used for facetting")
91 }
1244716e »
2014-02-24 Trim whitespace
92
93 base <- unique(ldply(values[has_all]))
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
94 if (!drop) {
95 base <- unique_combs(base)
96 }
1244716e »
2014-02-24 Trim whitespace
97
a4c85114 »
2011-05-18 Copy over all new files
98 # Systematically add on missing combinations
99 for (value in values[!has_all]) {
100 if (empty(value)) next;
1244716e »
2014-02-24 Trim whitespace
101
a4c85114 »
2011-05-18 Copy over all new files
102 old <- base[setdiff(names(base), names(value))]
1244716e »
2014-02-24 Trim whitespace
103 new <- unique(value[intersect(names(base), names(value))])
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
104 if (drop) {
105 new <- unique_combs(new)
106 }
1244716e »
2014-02-24 Trim whitespace
107
04b2eefd »
2011-05-19 Display working with 2d grid
108 base <- rbind(base, df.grid(old, new))
a4c85114 »
2011-05-18 Copy over all new files
109 }
989dbfe6 »
2012-04-17 Make empty data frames work with facets.
110
111 if (is.null(base)) {
112 stop("Faceting variables must have at least one value")
113 }
114
a4c85114 »
2011-05-18 Copy over all new files
115 base
116 }
117
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
118 ulevels <- function(x) {
119 if (is.factor(x)) {
120 x <- addNA(x, TRUE)
121 factor(levels(x), levels(x), exclude = NULL)
122 } else {
123 sort(unique(x))
124 }
125 }
126
127 unique_combs <- function(df) {
128 if (length(df) == 0) return()
1244716e »
2014-02-24 Trim whitespace
129
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
130 unique_values <- llply(df, ulevels)
1244716e »
2014-02-24 Trim whitespace
131 rev(expand.grid(rev(unique_values), stringsAsFactors = FALSE,
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
132 KEEP.OUT.ATTRS = TRUE))
133 }
134
04b2eefd »
2011-05-19 Display working with 2d grid
135 df.grid <- function(a, b) {
136 if (nrow(a) == 0) return(b)
137 if (nrow(b) == 0) return(a)
1244716e »
2014-02-24 Trim whitespace
138
04b2eefd »
2011-05-19 Display working with 2d grid
139 indexes <- expand.grid(
1244716e »
2014-02-24 Trim whitespace
140 i_a = seq_len(nrow(a)),
04b2eefd »
2011-05-19 Display working with 2d grid
141 i_b = seq_len(nrow(b))
142 )
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
143 unrowname(cbind(
1244716e »
2014-02-24 Trim whitespace
144 a[indexes$i_a, , drop = FALSE],
04b2eefd »
2011-05-19 Display working with 2d grid
145 b[indexes$i_b, , drop = FALSE]
d72cc9b0 »
2011-12-23 Support drop in facet_grid and facet_wrap.
146 ))
04b2eefd »
2011-05-19 Display working with 2d grid
147 }
148
a4c85114 »
2011-05-18 Copy over all new files
149 quoted_df <- function(data, vars) {
150 values <- eval.quoted(vars, data, emptyenv(), try = TRUE)
151 as.data.frame(compact(values))
152 }
153
154 # Arrange 1d structure into a grid
155 wrap_dims <- function(n, nrow = NULL, ncol = NULL) {
156 if (is.null(ncol) && is.null(nrow)) {
157 rc <- grDevices::n2mfrow(n)
3db9f8e4 »
2011-05-22 facet_wrap as.table working
158 nrow <- rc[2]
159 ncol <- rc[1]
a4c85114 »
2011-05-18 Copy over all new files
160 } else if (is.null(ncol)) {
161 ncol <- ceiling(n / nrow)
162 } else if (is.null(nrow)) {
163 nrow <- ceiling(n / ncol)
164 }
165 stopifnot(nrow * ncol >= n)
1244716e »
2014-02-24 Trim whitespace
166
a4c85114 »
2011-05-18 Copy over all new files
167 c(nrow, ncol)
4bcc38ae »
2011-12-01 Add missing newlines
168 }
Something went wrong with that request. Please try again.