1 |
#' Paginate listings |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' |
|
5 |
#' Pagination of a listing. This can be vertical for long listings with many |
|
6 |
#' rows or horizontal if there are many columns. |
|
7 |
#' |
|
8 |
#' @param lsting listing_df. The listing to paginate. |
|
9 |
#' @param lpp numeric(1) or NULL. Number of row lines (not counting titles and |
|
10 |
#' footers) to have per page. Standard is `70` while `NULL` disables vertical |
|
11 |
#' pagination. |
|
12 |
#' @param cpp numeric(1) or NULL. Width (in characters) of the pages for |
|
13 |
#' horizontal pagination. `NULL` (the default) indicates no horizontal |
|
14 |
#' pagination should be done. |
|
15 |
#' @inheritParams formatters::pag_indices_inner |
|
16 |
#' @inheritParams formatters::vert_pag_indices |
|
17 |
#' @inheritParams formatters::page_lcpp |
|
18 |
#' @inheritParams formatters::toString |
|
19 |
#' |
|
20 |
#' @returns A list of listings' objects that are meant to be on separated pages. |
|
21 |
#' For `pag_tt_indices` a list of paginated-groups of row-indices of `lsting`. |
|
22 |
#' |
|
23 |
#' @rdname paginate |
|
24 |
#' |
|
25 |
#' @examples |
|
26 |
#' dat <- ex_adae |
|
27 |
#' lsting <- as_listing(dat[1:25, ], disp_cols = c("USUBJID", "AESOC", "RACE", "AETOXGR", "BMRKR1")) |
|
28 |
#' |
|
29 |
#' mat <- matrix_form(lsting) |
|
30 |
#' |
|
31 |
#' cat(toString(mat)) |
|
32 |
#' |
|
33 |
#' paginate_listing(lsting, lpp = 10) |
|
34 |
#' |
|
35 |
#' paginate_listing(lsting, cpp = 100, lpp = 40) |
|
36 |
#' |
|
37 |
#' paginate_listing(lsting, cpp = 80, lpp = 40, verbose = TRUE) |
|
38 |
#' @export |
|
39 |
#' |
|
40 |
#' @return for `paginate_listing` a list containing separate |
|
41 |
#' `listing_df` objects for each page, for `pag_listing_indices`, |
|
42 |
#' a list of indices in the direction being paginated corresponding |
|
43 |
#' to the individual pages in that dimension. |
|
44 |
paginate_listing <- function(lsting, |
|
45 |
page_type = "letter", |
|
46 |
font_family = "Courier", |
|
47 |
font_size = 8, |
|
48 |
lineheight = 1, |
|
49 |
landscape = FALSE, |
|
50 |
pg_width = NULL, |
|
51 |
pg_height = NULL, |
|
52 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
53 |
lpp = NA_integer_, |
|
54 |
cpp = NA_integer_, |
|
55 |
colwidths = propose_column_widths(lsting), |
|
56 |
tf_wrap = !is.null(max_width), |
|
57 |
max_width = NULL, |
|
58 |
verbose = FALSE) { |
|
59 | 21x |
checkmate::assert_class(lsting, "listing_df") |
60 | 21x |
checkmate::assert_numeric(colwidths, lower = 0, len = length(listing_dispcols(lsting)), null.ok = TRUE) |
61 | 20x |
checkmate::assert_flag(tf_wrap) |
62 | 20x |
checkmate::assert_count(max_width, null.ok = TRUE) |
63 | 20x |
checkmate::assert_flag(verbose) |
64 | ||
65 | ||
66 | ||
67 | ||
68 | 20x |
indx <- paginate_indices(lsting, |
69 | 20x |
page_type = page_type, |
70 | 20x |
font_family = font_family, |
71 | 20x |
font_size = font_size, |
72 | 20x |
lineheight = lineheight, |
73 | 20x |
landscape = landscape, |
74 | 20x |
pg_width = pg_width, |
75 | 20x |
pg_height = pg_height, |
76 | 20x |
margins = margins, |
77 | 20x |
lpp = lpp, |
78 | 20x |
cpp = cpp, |
79 | 20x |
colwidths = colwidths, |
80 | 20x |
tf_wrap = tf_wrap, |
81 | 20x |
max_width = max_width, |
82 | 20x |
rep_cols = length(get_keycols(lsting)), |
83 | 20x |
verbose = verbose) |
84 | ||
85 | ||
86 | 20x |
vert_pags <- lapply(indx$pag_row_indices, |
87 | 20x |
function(ii) lsting[ii, ]) |
88 | 20x |
dispnames <- listing_dispcols(lsting) |
89 | 20x |
full_pag <- lapply(vert_pags, |
90 | 20x |
function(onepag) { |
91 | 30x |
if (!is.null(indx$pag_col_indices)) { |
92 | 30x |
lapply(indx$pag_col_indices, |
93 | 30x |
function(jj) { |
94 | 82x |
res <- onepag[, dispnames[jj], drop = FALSE] |
95 | 82x |
listing_dispcols(res) <- intersect(dispnames, names(res)) |
96 | 82x |
res |
97 |
}) |
|
98 |
} else { |
|
99 | ! |
list(onepag) |
100 |
} |
|
101 |
}) |
|
102 | ||
103 | 20x |
ret <- unlist(full_pag, recursive = FALSE) |
104 | 20x |
ret |
105 |
} |
|
106 | ||
107 |
#' @title Defunct functions |
|
108 |
#' |
|
109 |
#' @description |
|
110 |
#' These functions are defunct and their symbols will be removed entirely |
|
111 |
#' in a future release. |
|
112 |
#' @rdname defunct |
|
113 |
#' @inheritParams paginate_listing |
|
114 |
#' @export |
|
115 |
pag_listing_indices <- function(lsting, |
|
116 |
lpp = 15, |
|
117 |
colwidths = NULL, |
|
118 |
max_width = NULL, |
|
119 |
verbose = FALSE) { |
|
120 | 1x |
.Defunct("paginate_indices", package = "formatters") |
121 |
} |
1 |
setOldClass(c("listing_df", "tbl_df", "tbl", "data.frame")) |
|
2 |
setOldClass(c("MatrixPrintForm", "list")) |
|
3 | ||
4 |
#' @rdname listings |
|
5 |
#' @title Create a Listing from a `data.frame` or `tibble` |
|
6 |
#' |
|
7 |
#' @description `r lifecycle::badge("experimental")` |
|
8 |
#' |
|
9 |
#' Creates listings by using `cols` and `key_cols` to produce a compact and |
|
10 |
#' elegant representation of the `data.frame` or `tibble` in input. |
|
11 |
#' |
|
12 |
#' @param df data.frame or listing_df. The (non-listing) data.frame to be converted to a listing or |
|
13 |
#' the listing_df to be modified. |
|
14 |
#' @param key_cols character. Names of columns which should be treated as *key columns* |
|
15 |
#' when rendering the listing. Key columns allow you to group repeat occurrences. |
|
16 |
#' @param disp_cols character or NULL. Names of non-key columns which should be displayed when |
|
17 |
#' the listing is rendered. Defaults to all columns of `df` not named in `key_cols` or |
|
18 |
#' `non_disp_cols`. |
|
19 |
#' @param non_disp_cols character or NULL. Names of non-key columns to be excluded as display |
|
20 |
#' columns. All other non-key columns are then treated as display columns. Invalid if |
|
21 |
#' `disp_cols` is non-NULL. |
|
22 |
#' @param main_title character(1) or NULL. The main title for the listing, or |
|
23 |
#' `NULL` (the default). Must be length 1 non-NULL. |
|
24 |
#' @param subtitles character or NULL. A vector of subtitle(s) for the |
|
25 |
#' listing, or `NULL` (the default). |
|
26 |
#' @param main_footer character or NULL. A vector of main footer lines |
|
27 |
#' for the listing, or `NULL` (the default). |
|
28 |
#' @param prov_footer character or NULL. A vector of provenance strings |
|
29 |
#' for the listing, or `NULL` (the default). Each string element is placed on a new line. |
|
30 |
#' @param vec any. A column vector from a `listing_df` to be annotated as a key column. |
|
31 |
#' |
|
32 |
#' @return A `listing_df` object, sorted by the key columns. |
|
33 |
#' |
|
34 |
#' @details At its core, a `listing_df` object is a `tbl_df` object with a customized |
|
35 |
#' print method and support for the formatting and pagination machinery provided by |
|
36 |
#' the `formatters` package. |
|
37 |
#' |
|
38 |
#' `listing_df` objects have two 'special' types of columns: key columns and display columns. |
|
39 |
#' |
|
40 |
#' Key columns act as indexes, which means a number of things in practice. |
|
41 |
#' |
|
42 |
#' All key columns are also display columns. |
|
43 |
#' |
|
44 |
#' `listing_df` objects are always sorted by their set of key_columns at creation time. |
|
45 |
#' Any `listing_df` object which is not sorted by its full set of key columns (e.g., |
|
46 |
#' one whose rows have been reordered explicitly creation) is invalid and the behavior |
|
47 |
#' when rendering or paginating that object is undefined. |
|
48 |
#' |
|
49 |
#' Each value of a key column is printed only once per page and per unique combination of |
|
50 |
#' values for all higher-priority (i.e., to the left of it) key columns. Locations |
|
51 |
#' where a repeated value would have been printed within a key column for the same |
|
52 |
#' higher-priority-key combination on the same page are rendered as empty space. |
|
53 |
#' Note, determination of which elements to display within a key column at rendering is |
|
54 |
#' based on the underlying value; any non-default formatting applied to the column |
|
55 |
#' has no effect on this behavior. |
|
56 |
#' |
|
57 |
#' Display columns are columns which should be rendered, but are not key columns. By |
|
58 |
#' default this is all non-key columns in the incoming data, but in need not be. |
|
59 |
#' Columns in the underlying data which are neither key nor display columns remain |
|
60 |
#' within the object available for computations but *are not rendered during |
|
61 |
#' printing or export of the listing*. |
|
62 |
#' |
|
63 |
#' |
|
64 |
#' @examples |
|
65 |
#' dat <- ex_adae |
|
66 |
#' |
|
67 |
#' # This example demonstrates the listing with key_cols (values are grouped by USUBJID) and |
|
68 |
#' # multiple lines in prov_footer |
|
69 |
#' lsting <- as_listing(dat[1:25, ], |
|
70 |
#' key_cols = c("USUBJID", "AESOC"), |
|
71 |
#' main_title = "Example Title for Listing", |
|
72 |
#' subtitles = "This is the subtitle for this Adverse Events Table", |
|
73 |
#' main_footer = "Main footer for the listing", |
|
74 |
#' prov_footer = c( |
|
75 |
#' "You can even add a subfooter", "Second element is place on a new line", |
|
76 |
#' "Third string" |
|
77 |
#' ) |
|
78 |
#' ) %>% |
|
79 |
#' add_listing_col("AETOXGR") %>% |
|
80 |
#' add_listing_col("BMRKR1", format = "xx.x") %>% |
|
81 |
#' add_listing_col("AESER / AREL", fun = function(df) paste(df$AESER, df$AREL, sep = " / ")) |
|
82 |
#' |
|
83 |
#' mat <- matrix_form(lsting) |
|
84 |
#' |
|
85 |
#' cat(toString(mat)) |
|
86 |
#' |
|
87 |
#' # This example demonstrates the listing table without key_cols |
|
88 |
#' # and specifying the cols with disp_cols. |
|
89 |
#' dat <- ex_adae |
|
90 |
#' lsting <- as_listing(dat[1:25, ], disp_cols = c("USUBJID", "AESOC", "RACE", "AETOXGR", "BMRKR1")) |
|
91 |
#' |
|
92 |
#' mat <- matrix_form(lsting) |
|
93 |
#' |
|
94 |
#' cat(toString(mat)) |
|
95 |
#' |
|
96 |
#' @export |
|
97 |
as_listing <- function(df, |
|
98 |
key_cols = names(df)[1], |
|
99 |
disp_cols = NULL, |
|
100 |
non_disp_cols = NULL, |
|
101 |
main_title = NULL, |
|
102 |
subtitles = NULL, |
|
103 |
main_footer = NULL, |
|
104 |
prov_footer = NULL) { |
|
105 | 26x |
if (length(non_disp_cols) > 0 && length(intersect(key_cols, non_disp_cols)) > 0) { |
106 | 1x |
stop("Key column also listed in non_disp_cols. All key columns are by definition display columns") |
107 |
} |
|
108 | 25x |
if (!is.null(disp_cols) && !is.null(non_disp_cols)) { |
109 | 1x |
stop("Got non-null values for both disp_cols and non_disp_cols. This is not supported.") |
110 | 24x |
} else if (is.null(disp_cols)) { |
111 |
## non_disp_cols NULL is ok here |
|
112 | 9x |
cols <- setdiff(names(df), c(key_cols, non_disp_cols)) |
113 |
} else { |
|
114 |
## disp_cols non-null, non_disp_cols NULL |
|
115 | 15x |
cols <- disp_cols |
116 |
} |
|
117 | ||
118 | 24x |
df <- as_tibble(df) |
119 | 24x |
varlabs <- var_labels(df, fill = TRUE) |
120 | 24x |
o <- do.call(order, df[key_cols]) |
121 | 24x |
if (is.unsorted(o)) { |
122 | 9x |
message("sorting incoming data by key columns") |
123 | 9x |
df <- df[o, ] |
124 |
} |
|
125 | ||
126 |
## reorder the full set of cols to ensure key columns are first |
|
127 | 24x |
ordercols <- c(key_cols, setdiff(names(df), key_cols)) |
128 | 24x |
df <- df[, ordercols] |
129 | 24x |
var_labels(df) <- varlabs[ordercols] |
130 | ||
131 | 24x |
for (cnm in key_cols) { |
132 | 35x |
df[[cnm]] <- as_keycol(df[[cnm]]) |
133 |
} |
|
134 | ||
135 |
## key cols must be leftmost cols |
|
136 | 24x |
cols <- c(key_cols, setdiff(cols, key_cols)) |
137 | ||
138 | ||
139 | 24x |
class(df) <- c("listing_df", class(df)) |
140 |
## these all work even when the value is NULL |
|
141 | 24x |
main_title(df) <- main_title |
142 | 24x |
main_footer(df) <- main_footer |
143 | 24x |
subtitles(df) <- subtitles |
144 | 24x |
prov_footer(df) <- prov_footer |
145 | 24x |
listing_dispcols(df) <- cols |
146 | 24x |
df |
147 |
} |
|
148 | ||
149 | ||
150 |
#' @export |
|
151 |
#' @rdname listings |
|
152 |
as_keycol <- function(vec) { |
|
153 | 35x |
if (is.factor(vec)) { |
154 | 8x |
lab <- obj_label(vec) |
155 | 8x |
vec <- as.character(vec) |
156 | 8x |
obj_label(vec) <- lab |
157 |
} |
|
158 | 35x |
class(vec) <- c("listing_keycol", class(vec)) |
159 | 35x |
vec |
160 |
} |
|
161 | ||
162 | ||
163 |
#' @export |
|
164 |
#' @rdname listings |
|
165 |
is_keycol <- function(vec) { |
|
166 | 3598x |
inherits(vec, "listing_keycol") |
167 |
} |
|
168 | ||
169 | ||
170 | ||
171 |
#' @export |
|
172 |
#' @rdname listings |
|
173 |
get_keycols <- function(df) { |
|
174 | 151x |
names(which(sapply(df, is_keycol))) |
175 |
} |
|
176 | ||
177 |
#' @export |
|
178 |
#' @inherit formatters::matrix_form |
|
179 |
#' @seealso [formatters::matrix_form()] |
|
180 |
#' @param indent_rownames logical(1). Silently ignored, as listings do not have row names |
|
181 |
#' nor indenting structure. |
|
182 |
#' |
|
183 |
#' @examples |
|
184 |
#' |
|
185 |
#' lsting <- as_listing(mtcars) |
|
186 |
#' mf <- matrix_form(lsting) |
|
187 |
#' |
|
188 |
#' @return a `MatrixPrintForm` object |
|
189 |
setMethod( |
|
190 |
"matrix_form", "listing_df", |
|
191 |
rix_form <- function(obj, indent_rownames = FALSE) { |
|
192 |
## we intentionally silently ignore indent_rownames because listings have |
|
193 |
## no rownames, but formatters::vert_pag_indices calls matrix_form(obj, TRUE) |
|
194 |
## unconditionally. |
|
195 | 65x |
cols <- attr(obj, "listing_dispcols") |
196 | 65x |
listing <- obj[, cols] |
197 | 65x |
atts <- attributes(obj) |
198 | 65x |
atts$names <- cols |
199 | 65x |
attributes(listing) <- atts |
200 | ||
201 | 65x |
keycols <- get_keycols(listing) |
202 | ||
203 | ||
204 | 65x |
bodymat <- matrix("", |
205 | 65x |
nrow = nrow(listing), |
206 | 65x |
ncol = ncol(listing) |
207 |
) |
|
208 | ||
209 | 65x |
colnames(bodymat) <- names(listing) |
210 | ||
211 | ||
212 | 65x |
curkey <- "" |
213 | 65x |
for (i in seq_along(keycols)) { |
214 | 85x |
kcol <- keycols[i] |
215 | 85x |
kcolvec <- listing[[kcol]] |
216 | 85x |
curkey <- paste0(curkey, kcolvec) |
217 | 85x |
disp <- c(TRUE, tail(curkey, -1) != head(curkey, -1)) |
218 | 85x |
bodymat[disp, kcol] <- kcolvec[disp] |
219 |
} |
|
220 | ||
221 | 65x |
nonkeycols <- setdiff(names(listing), keycols) |
222 | 65x |
if (length(nonkeycols) > 0) { |
223 | 65x |
for (nonk in nonkeycols) { |
224 | 377x |
vec <- listing[[nonk]] |
225 | 377x |
vec <- vapply(vec, format_value, "", format = obj_format(vec)) |
226 | 377x |
bodymat[, nonk] <- vec |
227 |
} |
|
228 |
} |
|
229 | ||
230 | ||
231 | 65x |
fullmat <- rbind( |
232 | 65x |
var_labels(listing, fill = TRUE), |
233 | 65x |
bodymat |
234 |
) |
|
235 | ||
236 | 65x |
keycolaligns <- rbind( |
237 | 65x |
rep("center", length(keycols)), |
238 | 65x |
matrix("left", |
239 | 65x |
ncol = length(keycols), |
240 | 65x |
nrow = nrow(fullmat) - 1 |
241 |
) |
|
242 |
) |
|
243 | 65x |
MatrixPrintForm( |
244 | 65x |
strings = fullmat, |
245 | 65x |
spans = matrix(1, |
246 | 65x |
nrow = nrow(fullmat), |
247 | 65x |
ncol = ncol(fullmat) |
248 |
), |
|
249 | 65x |
ref_fnotes = list(), |
250 | 65x |
aligns = cbind( |
251 | 65x |
keycolaligns, |
252 | 65x |
matrix("center", |
253 | 65x |
nrow = nrow(fullmat), |
254 | 65x |
ncol = ncol(fullmat) - length(keycols) |
255 |
) |
|
256 |
), |
|
257 | 65x |
formats = matrix(1, |
258 | 65x |
nrow = nrow(fullmat), |
259 | 65x |
ncol = ncol(fullmat) |
260 |
), |
|
261 | 65x |
row_info = make_row_df(obj), |
262 | 65x |
nlines_header = 1, ## XXX this is probably wrong!!! |
263 | 65x |
nrow_header = 1, |
264 | 65x |
has_topleft = FALSE, |
265 | 65x |
has_rowlabs = FALSE, |
266 | 65x |
expand_newlines = TRUE, |
267 | 65x |
main_title = main_title(obj), |
268 | 65x |
subtitles = subtitles(obj), |
269 | 65x |
page_titles = page_titles(obj), |
270 | 65x |
main_footer = main_footer(obj), |
271 | 65x |
prov_footer = prov_footer(obj) |
272 |
) |
|
273 |
} |
|
274 |
) |
|
275 | ||
276 | ||
277 |
#' @export |
|
278 |
#' @rdname listings |
|
279 | 129x |
listing_dispcols <- function(df) attr(df, "listing_dispcols") %||% character() |
280 | ||
281 |
#' @export |
|
282 |
#' @param new character. Names of columns to be added to |
|
283 |
#' the set of display columns. |
|
284 |
#' @rdname listings |
|
285 |
add_listing_dispcol <- function(df, new) { |
|
286 | 20x |
listing_dispcols(df) <- c(listing_dispcols(df), new) |
287 | 20x |
df |
288 |
} |
|
289 |
#' @export |
|
290 |
#' @param value character. New value. |
|
291 |
#' @rdname listings |
|
292 |
`listing_dispcols<-` <- function(df, value) { |
|
293 | 126x |
if (!is.character(value)) { |
294 | ! |
stop( |
295 | ! |
"dispcols must be a character vector of column names, got ", |
296 | ! |
"object of class: ", paste(class(value), collapse = ",") |
297 |
) |
|
298 |
} |
|
299 | 126x |
chk <- setdiff(value, names(df)) ## remember setdiff is not symmetrical |
300 | 126x |
if (length(chk) > 0) { |
301 | ! |
stop( |
302 | ! |
"listing display columns must be columns in the underlying data. ", |
303 | ! |
"Column(s) ", paste(chk, collapse = ", "), " not present in the data." |
304 |
) |
|
305 |
} |
|
306 | 126x |
attr(df, "listing_dispcols") <- unique(value) |
307 | 126x |
df |
308 |
} |
|
309 | ||
310 | ||
311 | ||
312 |
#' @rdname listings |
|
313 |
#' |
|
314 |
#' @param name character(1). Name of the existing or new column to be |
|
315 |
#' displayed when the listing is rendered. |
|
316 |
#' @param fun function or NULL. A function which accepts \code{df} and |
|
317 |
#' returns the vector for a new column, which is added to \code{df} as |
|
318 |
#' \code{name}, or NULL if marking an existing column as |
|
319 |
#' a listing column. |
|
320 |
#' @inheritParams formatters::format_value |
|
321 |
#' |
|
322 |
#' @return `df`, with `name` created (if necessary) and marked for |
|
323 |
#' display during rendering. |
|
324 |
#' |
|
325 |
#' @export |
|
326 |
add_listing_col <- function(df, name, fun = NULL, format = NULL, na_str = "-") { |
|
327 | 20x |
if (!is.null(fun)) { |
328 | 1x |
vec <- fun(df) |
329 | 19x |
} else if (name %in% names(df)) { |
330 | 19x |
vec <- df[[name]] |
331 |
} else { |
|
332 | ! |
stop( |
333 | ! |
"Column '", name, "' not found. name argument must specify an existing column when ", |
334 | ! |
"no generating function (fun argument) is specified." |
335 |
) |
|
336 |
} |
|
337 | ||
338 | 20x |
if (!is.null(format)) { |
339 | 7x |
vec <- df[[name]] |
340 | 7x |
obj_format(vec) <- format |
341 |
} |
|
342 | ||
343 | 20x |
obj_na_str(vec) <- na_str |
344 | ||
345 |
## this works for both new and existing columns |
|
346 | 20x |
df[[name]] <- vec |
347 | 20x |
df <- add_listing_dispcol(df, name) |
348 | 20x |
df |
349 |
} |
1 |
## #' Print a listing to the terminal |
|
2 |
## #' @param x listing_df. the listing |
|
3 |
## #' @param ... ANY. unused |
|
4 |
## #' @return prints the listing object to the screen and silently returns the object |
|
5 |
## #' @export |
|
6 |
## setMethod("print", "listing_df", |
|
7 |
## function(x, ...) { |
|
8 |
## cat(toString(listing_matrix_form(x))) |
|
9 |
## invisible(x) |
|
10 |
## }) |
|
11 | ||
12 |
#' Methods for `listing_df` objects |
|
13 |
#' |
|
14 |
#' See core documentation in \code{formatters} for descriptions |
|
15 |
#' of these functions. |
|
16 |
#' |
|
17 |
#' @export |
|
18 |
#' @inheritParams formatters::toString |
|
19 |
#' @param x listing_df. The listing. |
|
20 |
#' @param ... dots. See `toString` method in \code{formatters} for all parameters. |
|
21 |
#' @method print listing_df |
|
22 |
#' @name listing_methods |
|
23 |
print.listing_df <- function(x, widths = NULL, tf_wrap = FALSE, max_width = NULL, ...) { |
|
24 | ! |
cat(toString(matrix_form(x), widths = widths, tf_wrap = tf_wrap, max_width = max_width, ...)) |
25 | ! |
invisible(x) |
26 |
} |
|
27 | ||
28 |
#' @exportMethod toString |
|
29 |
#' @name listing_methods |
|
30 |
#' @aliases toString,listing_df-method |
|
31 |
setMethod("toString", "listing_df", function(x, ...) { |
|
32 | 2x |
toString(matrix_form(x), ...) |
33 |
}) |
|
34 | ||
35 |
## because rle in base is too much of a stickler for being atomic |
|
36 |
basic_run_lens <- function(x) { |
|
37 | 65x |
n <- length(x) |
38 | 65x |
if (n == 0) { |
39 | ! |
return(integer()) |
40 |
} |
|
41 | ||
42 | 65x |
y <- x[-1L] != x[-n] |
43 | 65x |
i <- c(which(y), n) |
44 | 65x |
diff(c(0L, i)) |
45 |
} |
|
46 | ||
47 | ||
48 |
#' @rdname vec_nlines |
|
49 |
#' @param df listing_df. The listing. |
|
50 |
#' @param colnm Column name |
|
51 |
#' @param colvec Column values based on colnm |
|
52 |
format_colvector <- function(df, colnm, colvec = df[[colnm]]) { |
|
53 | 464x |
if (missing(colvec) && !(colnm %in% names(df))) { |
54 | ! |
stop("column ", colnm, " not found") |
55 |
} |
|
56 | 464x |
na_str <- obj_na_str(colvec) |
57 | 464x |
if (is.null(na_str) || all(is.na(na_str))) { |
58 | 410x |
na_str <- rep("-", max(1L, length(na_str))) |
59 |
} |
|
60 | ||
61 | 464x |
strvec <- vapply(colvec, format_value, "", format = obj_format(colvec), na_str = na_str) |
62 | 464x |
strvec |
63 |
} |
|
64 | ||
65 |
#' Utilities for formatting a listing column |
|
66 |
#' |
|
67 |
#' For `vec_nlines`, calculate the number of lines each element of a column vector will |
|
68 |
#' take to render. For `format_colvector`, |
|
69 |
#' |
|
70 |
#' @param vec any vector. A column vector to be rendered into ASCII. |
|
71 |
#' @param max_width numeric (or NULL). The width the column will be |
|
72 |
#' rendered in. |
|
73 |
#' @return a numeric vector of the number of lines elementwise that |
|
74 |
#' will be needed to render the elements of \code{vec} to width |
|
75 |
#' \code{max_width}. |
|
76 |
#' @keywords internal |
|
77 | 464x |
setGeneric("vec_nlines", function(vec, max_width = NULL) standardGeneric("vec_nlines")) |
78 | ||
79 |
#' @rdname vec_nlines |
|
80 |
#' @param vec A vector. |
|
81 |
#' @keywords internal |
|
82 |
setMethod("vec_nlines", "ANY", function(vec, max_width = NULL) { |
|
83 | 464x |
strvec <- wrap_txt(format_colvector(colvec = vec), max_width = max_width, hard = TRUE) |
84 | 464x |
mtchs <- gregexpr("\n", strvec, fixed = TRUE) |
85 | 464x |
1L + vapply(mtchs, function(vi) sum(vi > 0), 1L) |
86 |
}) |
|
87 | ||
88 |
## setMethod("vec_nlines", "character", function(vec, max_width = NULL) { |
|
89 |
## strvec <- wrap_txt(format_colvector(colvec = vec), max_width = max_width, hard = TRUE) |
|
90 |
## mtchs <- gregexpr("\n", strvec, fixed = TRUE) |
|
91 |
## 1L + vapply(mtchs, function(vi) sum(vi > 0), 1L) |
|
92 |
## }) |
|
93 | ||
94 |
## setMethod("vec_nlines", "factor", function(vec, max_width = NULL) { |
|
95 |
## lvl_nlines <- vec_nlines(levels(vec), max_width = max_width) |
|
96 |
## ret <- lvl_nlines[vec] |
|
97 |
## ret[is.na(ret)] <- format_value(NA_character |
|
98 |
## }) |
|
99 | ||
100 |
#' Make pagination dataframe for a listing |
|
101 |
#' @export |
|
102 |
#' @inheritParams formatters::make_row_df |
|
103 |
#' @param tt listing_df. The listing to be rendered |
|
104 |
#' @param visible_only logical(1). Ignored, as listings |
|
105 |
#' do not have non-visible structural elements. |
|
106 |
#' |
|
107 |
#' @examples |
|
108 |
#' lsting <- as_listing(mtcars) |
|
109 |
#' mf <- matrix_form(lsting) |
|
110 |
#' |
|
111 |
#' @return a data.frame with pagination information. |
|
112 |
#' @seealso \code{\link[formatters]{make_row_df}} |
|
113 |
setMethod( |
|
114 |
"make_row_df", "listing_df", |
|
115 |
function(tt, colwidths = NULL, visible_only = TRUE, |
|
116 |
rownum = 0, |
|
117 |
indent = 0L, |
|
118 |
path = character(), |
|
119 |
incontent = FALSE, |
|
120 |
repr_ext = 0L, |
|
121 |
repr_inds = integer(), |
|
122 |
sibpos = NA_integer_, |
|
123 |
nsibs = NA_integer_) { |
|
124 |
## assume sortedness by keycols |
|
125 | 66x |
keycols <- get_keycols(tt) |
126 | 66x |
dispcols <- listing_dispcols(tt) |
127 | 66x |
abs_rownumber <- seq_along(tt[[1]]) |
128 | 66x |
if (length(keycols) >= 1) { |
129 | 65x |
runlens <- basic_run_lens(tt[[tail(keycols, 1)]]) |
130 |
} else { |
|
131 | 1x |
runlens <- rep(1, NROW(tt)) |
132 |
} |
|
133 | 66x |
sibpos <- unlist(lapply(runlens, seq_len)) |
134 | 66x |
nsibs <- rep(runlens, times = runlens) |
135 | 66x |
extents <- rep(1L, nrow(tt)) |
136 | 66x |
if (length(colwidths) > 0 && length(colwidths) != length(dispcols)) { |
137 | ! |
stop( |
138 | ! |
"Non-null colwidths vector must be the same length as the number of display columns.\n", |
139 | ! |
"Got: ", length(colwidths), "(", length(dispcols), " disp cols)." |
140 |
) |
|
141 |
} |
|
142 | 66x |
if (length(colwidths) > 0) { |
143 | ! |
names(colwidths) <- dispcols |
144 |
} |
|
145 |
## extents is a row-wise vector of extents, for each col, we update |
|
146 |
## if that column has any rows wider than the previously recorded extent. |
|
147 | 66x |
for (col in dispcols) { |
148 |
## duplicated from matrix_form method, refactor! |
|
149 | 464x |
col_ext <- vec_nlines(tt[[col]], max_width = colwidths[col]) |
150 | 464x |
extents <- ifelse(col_ext > extents, col_ext, extents) |
151 |
} |
|
152 | 66x |
ret <- data.frame( |
153 | 66x |
label = "", name = "", |
154 | 66x |
abs_rownumber = abs_rownumber, |
155 | 66x |
path = I(as.list(rep(NA_character_, NROW(tt)))), |
156 | 66x |
pos_in_siblings = sibpos, |
157 | 66x |
n_siblings = nsibs, |
158 | 66x |
self_extent = extents, |
159 | 66x |
par_extent = 0L, |
160 | 66x |
reprint_inds = I(replicate(NROW(tt), list(integer()))), |
161 | 66x |
node_class = "listing_df", |
162 | 66x |
indent = 0L, |
163 | 66x |
nrowrefs = 0L, ## XXX this doesn't support footnotes |
164 | 66x |
ncellrefs = 0L, ## XXX this doesn't support footnotes |
165 | 66x |
nreflines = 0L, ## XXX this doesn't support footnotes |
166 | 66x |
force_page = FALSE, |
167 | 66x |
page_title = NA_character_, |
168 | 66x |
trailing_sep = NA_character_ |
169 |
) |
|
170 | 66x |
stopifnot(identical( |
171 | 66x |
names(ret), |
172 | 66x |
names(pagdfrow( |
173 | 66x |
nm = "", lab = "", rnum = 1L, pth = NA_character_, extent = 1L, |
174 | 66x |
rclass = "" |
175 |
)) |
|
176 |
)) |
|
177 | 66x |
ret |
178 |
} |
|
179 |
) |
|
180 | ||
181 |
## tt$sibpos <- unlist(lapply( |
|
182 |
## ## don't support pathing for now |
|
183 |
## tt$path <- I(lapply(1:NROW(tt), |
|
184 |
## function(i) { |
|
185 |
## retpath <- character(2*length(keycols)) |
|
186 |
## for(j in seq_along(keycols)) { |
|
187 |
## retpath[2*j - 1] <- keycols[j] |
|
188 |
## retpath[2*j] <- tt[i, keycols[j], drop = TRUE] |
|
189 |
## } |
|
190 |
## retpath |
|
191 |
## })) |
|
192 |
## spl <- split(tt, tt[keycols]) |
|
193 |
## spl <- spl[vapply(spl, function(y) NROW(y) > 0, NA)] |
|
194 |
## dfs <- lapply(spl, function(df) { |
|
195 |
## df <- df[order(df$abs_rownumber),] |
|
196 |
## ndf <- NROW(df) |
|
197 |
## lapply(1:ndf, function(i) { |
|
198 |
## rw <- df[i,] |
|
199 |
## stopifnot(nrow(rw) == 1) |
|
200 |
## pagdfrow(nm = "", |
|
201 |
## lab = "", |
|
202 |
## rnum = rw$abs_rownumber, |
|
203 |
## pth = NA_character_, |
|
204 |
## sibpos = i, |
|
205 |
## nsibs = ndf, |
|
206 |
## extent = 1L, |
|
207 |
## rclass = "listing_df", |
|
208 |
## repind = integer()) |
|
209 |
## }) |
|
210 |
## }) |
|
211 |
## ret <- do.call(rbind, unlist(dfs, recursive = FALSE)) |
|
212 |
## ret <- ret[order(ret$abs_rownumber),] |
|
213 |
## ret |
|
214 |
## }) |
|
215 | ||
216 |
#' @export |
|
217 |
#' @param x listing_df. The listing. |
|
218 |
#' @inheritParams base::Extract |
|
219 |
#' @param i ANY. Passed to base `[` methods. |
|
220 |
#' @param j ANY. Passed to base `[` methods. |
|
221 |
#' @aliases [,listing_df-method |
|
222 |
#' @rdname listing_methods |
|
223 |
#' @keywords internal |
|
224 |
setMethod( |
|
225 |
"[", "listing_df", |
|
226 |
function(x, i, j, drop = FALSE) { |
|
227 | ! |
xattr <- attributes(x) |
228 | ! |
xattr$names <- xattr$names[j] |
229 | ! |
res <- NextMethod() |
230 | ! |
if (!drop) { |
231 | ! |
attributes(res) <- xattr |
232 |
} |
|
233 | ! |
res |
234 |
} |
|
235 |
) |
|
236 | ||
237 |
#' @rdname listing_methods |
|
238 |
#' @param obj The object. |
|
239 |
#' @export |
|
240 |
#' @return for getter methods, the value of the aspect of |
|
241 |
#' \code{obj}; for setter methods, \code{obj} with |
|
242 |
#' the relevant element of the listing updated. |
|
243 |
#' |
|
244 |
#' @examples |
|
245 |
#' |
|
246 |
#' lsting <- as_listing(mtcars) |
|
247 |
#' main_title(lsting) <- "Hi there" |
|
248 |
#' |
|
249 |
#' main_title(lsting) |
|
250 |
setMethod( |
|
251 |
"main_title", "listing_df", |
|
252 | 68x |
function(obj) attr(obj, "main_title") %||% character() |
253 |
) |
|
254 | ||
255 |
#' @rdname listing_methods |
|
256 |
#' @export |
|
257 |
setMethod( |
|
258 |
"subtitles", "listing_df", |
|
259 | 67x |
function(obj) attr(obj, "subtitles") %||% character() |
260 |
) |
|
261 |
#' @rdname listing_methods |
|
262 |
#' @export |
|
263 |
setMethod( |
|
264 |
"main_footer", "listing_df", |
|
265 | 67x |
function(obj) attr(obj, "main_footer") %||% character() |
266 |
) |
|
267 |
#' @rdname listing_methods |
|
268 |
#' @export |
|
269 |
setMethod( |
|
270 |
"prov_footer", "listing_df", |
|
271 | 67x |
function(obj) attr(obj, "prov_footer") %||% character() |
272 |
) |
|
273 | ||
274 |
.chk_value <- function(val, fname, len_one = FALSE, null_ok = TRUE) { |
|
275 | 110x |
if (null_ok && is.null(val)) { |
276 | 96x |
return(TRUE) |
277 |
} |
|
278 | 14x |
if (!is.character(val)) { |
279 | 4x |
stop("value for ", fname, " must be a character, got ", |
280 | 4x |
"object of class: ", paste(class(val), collapse = ","), |
281 | 4x |
call. = FALSE |
282 |
) |
|
283 |
} |
|
284 | 10x |
if (len_one && length(val) > 1) { |
285 | 1x |
stop( |
286 | 1x |
"value for ", fname, " must be length <= 1, got ", |
287 | 1x |
"vector of length ", length(val) |
288 |
) |
|
289 |
} |
|
290 | 9x |
TRUE |
291 |
} |
|
292 | ||
293 |
#' @rdname listing_methods |
|
294 |
#' @export |
|
295 |
setMethod( |
|
296 |
"main_title<-", "listing_df", |
|
297 |
function(obj, value) { |
|
298 |
## length 1 restriction is to match rtables behavior |
|
299 |
## which currently enforces this (though incompletely) |
|
300 | 30x |
.chk_value(value, "main_title", len_one = TRUE) |
301 | 28x |
attr(obj, "main_title") <- value |
302 | 28x |
obj |
303 |
} |
|
304 |
) |
|
305 | ||
306 |
#' @rdname listing_methods |
|
307 |
#' @export |
|
308 |
setMethod( |
|
309 |
"subtitles<-", "listing_df", |
|
310 |
function(obj, value) { |
|
311 | 26x |
.chk_value(value, "subtitles") |
312 | 25x |
attr(obj, "subtitles") <- value |
313 | 25x |
obj |
314 |
} |
|
315 |
) |
|
316 | ||
317 |
#' @rdname listing_methods |
|
318 |
#' @export |
|
319 |
setMethod( |
|
320 |
"main_footer<-", "listing_df", |
|
321 |
function(obj, value) { |
|
322 | 28x |
.chk_value(value, "main_footer") |
323 | 27x |
attr(obj, "main_footer") <- value |
324 | 27x |
obj |
325 |
} |
|
326 |
) |
|
327 | ||
328 |
#' @rdname listing_methods |
|
329 |
#' @export |
|
330 |
setMethod( |
|
331 |
"prov_footer<-", "listing_df", |
|
332 |
function(obj, value) { |
|
333 | 26x |
.chk_value(value, "prov_footer") |
334 | 25x |
attr(obj, "prov_footer") <- value |
335 | 25x |
obj |
336 |
} |
|
337 |
) |