-
Notifications
You must be signed in to change notification settings - Fork 10
/
stat-format-table.R
233 lines (223 loc) · 10.2 KB
/
stat-format-table.R
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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
#' @title Select and slice a tibble nested in \code{data}
#'
#' @description \code{stat_fmt_tb} selects, reorders and/or renames columns and
#' or rows of a tibble nested in \code{data}. This stat is intended to be used
#' to pre-process \code{tibble} objects mapped to the \code{label} aesthetic
#' before adding them to a plot with \code{geom_table}.
#'
#' @param mapping The aesthetic mapping, usually constructed with
#' \code{\link[ggplot2]{aes}} or \code{\link[ggplot2]{aes_}}. Only needs to be
#' set at the layer level if you are overriding the plot defaults.
#' @param data A layer specific dataset - only needed if you want to override
#' the plot defaults.
#' @param geom The geometric object to use display the data
#' @param position The position adjustment to use for overlapping points on this
#' layer
#' @param show.legend logical. Should this layer be included in the legends?
#' \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE}
#' never includes, and \code{TRUE} always includes.
#' @param inherit.aes If \code{FALSE}, overrides the default aesthetics, rather
#' than combining with them. This is most useful for helper functions that
#' define both data and aesthetics and shouldn't inherit behaviour from the
#' default plot specification, e.g. \code{\link[ggplot2]{borders}}.
#' @param ... other arguments passed on to \code{\link[ggplot2]{layer}}. This
#' can include aesthetics whose values you want to set, not map. See
#' \code{\link[ggplot2]{layer}} for more details.
#' @param na.rm a logical indicating whether \code{NA} values should be stripped
#' before the computation proceeds.
#' @param digits integer indicating the number of significant digits to be
#' retained in data.
#' @param tb.vars,tb.rows character or numeric vectors, optionally named, used
#' to select and/or rename the columns or rows in the table
#' returned.
#' @param table.theme NULL, list or function A 'gridExtra' \code{ttheme}
#' definition, or a constructor for a \code{ttheme} or \code{NULL} for
#' default.
#' @param table.rownames,table.colnames logical flag to enable or disabling
#' printing of row names and column names.
#' @param table.hjust numeric Horizontal justification for the core and column
#' headings of the table.
#' @param parse If \code{TRUE}, the labels will be parsed into expressions and
#' displayed as described in \code{?plotmath}.
#'
#' @seealso See \code{\link{geom_table}} for details on how tables respond
#' to mapped aesthetics and table themes. For details on predefined table
#' themes see \code{\link{ttheme_gtdefault}}.
#'
#' @section Computed variables: The output of sequentially applying
#' \code{\link[dplyr]{slice}} with \code{tb.rows} as argument and
#' \code{\link[dplyr]{select}} with \code{tb.vars} to a list variable
#' list mapped to \code{label} and containing a single tibble per row
#' in \code{data}.
#'
#' @return A plot layer instance. Using as output \code{data} a copy of the
#' input \code{data} in which the data frames mapped to \code{label} have been
#' modified.
#'
#' @export
#'
#' @examples
#' my.df <-
#' tibble::tibble(
#' x = c(1, 2),
#' y = c(0, 4),
#' group = c("A", "B"),
#' tbs = list(a = tibble::tibble(Xa = 1:6, Y = rep(c("x", "y"), 3)),
#' b = tibble::tibble(Xb = 1:3, Y = "x"))
#' )
#'
#' ggplot(my.df, aes(x, y, label = tbs)) +
#' stat_fmt_tb() +
#' expand_limits(x = c(0,3), y = c(-2, 6))
#'
#' # Hide column names, diplay row names
#' ggplot(my.df, aes(x, y, label = tbs)) +
#' stat_fmt_tb(table.colnames = FALSE,
#' table.rownames = TRUE) +
#' expand_limits(x = c(0,3), y = c(-2, 6))
#'
#' # Use a theme for the table
#' ggplot(my.df, aes(x, y, label = tbs)) +
#' stat_fmt_tb(table.theme = ttheme_gtlight) +
#' expand_limits(x = c(0,3), y = c(-2, 6))
#'
#' # selection and renaming by column position
#' ggplot(my.df, aes(x, y, label = tbs)) +
#' stat_fmt_tb(tb.vars = c(value = 1, group = 2),
#' tb.rows = 1:3) +
#' expand_limits(x = c(0,3), y = c(-2, 6))
#'
#' # selection, reordering and renaming by column position
#' ggplot(my.df, aes(x, y, label = tbs)) +
#' stat_fmt_tb(tb.vars = c(group = 2, value = 1),
#' tb.rows = 1:3) +
#' expand_limits(x = c(0,3), y = c(-2, 6))
#'
#' # selection and renaming, using partial matching to column name
#' ggplot(my.df, aes(x, y, label = tbs)) +
#' stat_fmt_tb(tb.vars = c(value = "X", group = "Y"),
#' tb.rows = 1:3) +
#' expand_limits(x = c(0,3), y = c(-2, 6))
#'
stat_fmt_tb <- function(mapping = NULL,
data = NULL,
geom = "table",
tb.vars = NULL,
tb.rows = NULL,
digits = 3,
position = "identity",
table.theme = NULL,
table.rownames = FALSE,
table.colnames = TRUE,
table.hjust = 0.5,
parse = FALSE,
na.rm = FALSE,
show.legend = FALSE,
inherit.aes = TRUE,
...) {
ggplot2::layer(
stat = StatFmtTb, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(tb.vars = tb.vars,
tb.rows = tb.rows,
digits = digits,
table.theme = table.theme,
table.rownames = table.rownames,
table.colnames = table.colnames,
table.hjust = table.hjust,
parse = parse,
na.rm = na.rm,
...)
)
}
#' @rdname ggpp-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatFmtTb <-
ggplot2::ggproto("StatFmtTb", ggplot2::Stat,
compute_group = function(data,
scales,
tb.vars = NULL,
tb.rows = NULL,
digits = 3) {
stopifnot(is.list(data$label))
for (tb.idx in seq_along(data$label)) {
temp_tb <- data$label[tb.idx][[1]]
if (!is.data.frame(temp_tb)) {
message("Skipping object of class ", class(temp_tb))
next()
}
num.cols <- sapply(temp_tb, is.numeric)
temp_tb[num.cols] <-
signif(temp_tb[num.cols], digits = digits)
if (!is.null(tb.vars)) {
if (is.character(tb.vars)) {
idxs <- pmatch(tb.vars, colnames(temp_tb))
if (length(idxs) < length(tb.vars) || anyNA(idxs)) {
warning("Attempt to select nonexistent columns")
idxs <- stats::na.omit(idxs)
# no renaming possible, as we do not know which name was not matched
tb.vars <- unname(tb.vars)
}
} else {
idxs <- unname(tb.vars)
if (any(idxs > ncol(temp_tb))) {
warning("Attempt to select nonexistent columns")
idxs <- idxs[idxs <= ncol(temp_tb)]
tb.vars <- tb.vars[idxs]
}
}
# if (length(idxs) < ncol(temp_tb)) {
# message("Dropping column(s) from table.")
# }
if (length(idxs) < 1L) {
message("No matching column(s).")
temp_tb <- NULL
} else {
temp_tb <- temp_tb[ , idxs]
if (!is.null(names(tb.vars))) {
# support renaming of only some selected columns
selector <- names(tb.vars) != ""
colnames(temp_tb)[selector] <- names(tb.vars)[selector]
}
}
}
if (!is.null(tb.rows) && !is.null(temp_tb)) {
if (is.character(tb.rows)) {
idxs <- pmatch(tb.rows, rownames(temp_tb))
if (length(idxs) < length(tb.rows) || anyNA(idxs)) {
warning("Attempt to select nonexistent rows")
idxs <- stats::na.omit(idxs)
# no renaming possible, as we do not know which name was not matched
tb.rows <- unname(tb.rows)
}
} else {
idxs <- unname(tb.rows)
if (any(idxs > nrow(temp_tb))) {
warning("Attempt to select nonexistent rows")
idxs <- idxs[idxs <= nrow(temp_tb)]
tb.rows <- tb.rows[idxs]
}
}
# if (length(idxs) < nrow(temp_tb)) {
# message("Dropping row(s) from table.")
# }
if (length(idxs) < 1L) {
warning("No matching row(s).")
temp_tb <- NULL
} else {
temp_tb <- temp_tb[idxs, ]
if (!is.null(names(tb.rows))) {
# support renaming of only some selected rows
selector <- names(tb.rows) != ""
colnames(temp_tb)[selector] <- names(tb.rows)[selector]
}
}
}
data$label[tb.idx] <- list(temp_tb)
}
data
},
required_aes = c("x", "y", "label")
)