-
Notifications
You must be signed in to change notification settings - Fork 7
/
gentlg.R
358 lines (353 loc) · 12.9 KB
/
gentlg.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
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
#' Output a tidytlg table
#'
#' Generate and output a huxtable with desired properties
#' During this function call, the huxtable can be written to an RTF or
#' displayed in HTML. `gentlg` is vectorized, see parameter descriptions
#' to learn for which arguments.
#'
#' @author Steven Haesendonckx <shaesen2@@its.jnj.com>
#' @author Pelagia Alexandra Papadopoulou <ppapadop@@its.jnj.com>
#'
#' @param huxme (optional) For tables and listings, A list of input dataframes
#' containing all columns of interest. For graphs, either NULL or a list of ggplot
#' objects. Vectorized.
#' @param tlf (optional) String, representing the output choice. Choices are
#' "Table" "Listing" "Figure". Abbreviations are allowed eg "T" for Table.
#' Strings can be either upper- or lowercase. Vectorized. (Default = "Table")
#' @param format (optional) String, representing the output format. Choices are
#' "rtf" and "html". Strings can be either upper- or lowercase.(Default = "rtf")
#' @param colspan (optional) A list of character vectors representing the
#' spanning headers to be used for the table or listing. The first vector
#' represents the top spanning header, etc. Each vector should have a length
#' equal to the number of columns in the output data frame. A spanning header
#' is identified through the use of the same column name in adjacent elements.
#' Vectorized.
#' @param idvars (optional) Character vector defining the columns of a listing
#' where repeated values should be removed recursively. If NULL then
#' all column names are used in the algorithm. If NA, then the listing remains
#' as is.
#' @param plotnames (optional) Character vector containing the names of the png
#' files, with their extension to be incorporated for figure outputs.
#' The png files need to be located in the path defined by the parameter `opath`.
#' @param plotwidth (optional) Numerical value that indicates the plot width in
#' cm for figure outputs. (Default = 6)
#' @param plotheight (optional) Numerical value that indicates the plot height
#' in cm for figure outputs. (Default = 5)
#' @param wcol (optional) Can be a single numerical value that represents the
#' width of the first column or a vector, specifying the lengths of all columns
#' in the final table or listing.\cr
#' When a single numerical value is used, this will be taken as the column width
#' for the first column. The other columns will be equally spaced across the
#' remainder of the available space. Alternatively, a vector can be used to
#' represent the widths of all columns in the final output. The order of the
#' arguments needs to correspond to the order of the columns in the `huxme`
#' dataset, that are not part of the formatting algorithms
#' (eg anbr, roworder, newpage, newrow, indentme, boldme, by_value, by_order).
#' The sum of the widths in the vector needs to be less or equal to one. When
#' 'format="HTML"' wcol can take only one value, the width of the first column.
#' (Default = 0.45)
#' @param opath (optional) File path pointing to the output files
#' (including .png files for graphs). (Default = ".")
#' @param orientation (optional) String: "portrait" or "landscape".
#' (Default = "portrait")
#' @param file (required) String. Output identifier.
#' File name will be adjusted to be lowercase and have - and _ removed,
#' this will not affect table title.
#' @param title_file An Excel file that will be read in
#' with `readxl::read_excel()` to be used as the `title` and `footers` arugment.
#' The use of `title` or `footers` will override the values passed by this
#' argument. The file should be either an xls or xlsx file with the columns
#' 'TABLE ID', 'IDENTIFIER', and TEXT'. The file will be read in, subset to
#' where the tblid matches the tlf argument, and identifiers with 'title' or
#' 'footnote' will be used to populate the table.
#' @param title (required) String. Title of the output. Vectorized.
#' @param footers (optional) Character vector, containing strings of footnotes
#' to be included. Vectorized.
#' @param print.hux (optional) Logical, indicating whether the output should be
#' printed to RTF ('format' = "rtf") / displayed as HTML ('format' = "HTML").
#' (Default = TRUE) Note that RTF is written using `quick_rtf_jnj()`
#' function and that the HTML is displayed via the huxtable::print_html
#' function.
#' @param watermark (optional) String containing the desired watermark for
#' RTF outputs. Vectorized.
#' @param colheader (optional) Character vector that contains the column labels
#' for a table or listing. Default uses the column labels of huxme. Vectorized.
#' @param pagenum (optional) Logical. When true page numbers are added on the
#' right side of the footer section in the format page x/y.
#' Vectorized. (Default = FALSE)
#' @param bottom_borders (optional) Matrix or `"old_format"`. A matrix indicating where to add the bottom
#' borders. Vectorized. See [add_bottom_borders()] for more information. If `"old_format"`,
#' then borders are added to the `colspan` and `colheader` rows. (Default = "old_format").
#' @param border_fns (optional) List. A list of functions that transform the matrix
#' passed to `bottom_borders`. Vectorized. See [add_bottom_borders()] for more information.
#'
#' @section Huxme Details:
#' For tables and listings, formatting of the output can be dictated through the
#' formatting columns
#' (`newrows`, `indentme`, `boldme`, `newpage`), present in the input dataframe.
#' The final huxtable will display all columns of the input dataframe, except
#' any recognized formatting/sorting columns.
#' For tables, the algorithm uses
#' the column `label` as first column. The remaining columns are treated as
#' summary columns.
#' For graphs, you can pass a ggplot object directly into huxme and gentlg will
#' save a png with with `ggplot2::ggsave()` and output an rtf.
#'
#' @return A list of formatted huxtables with desired properties for output to an RTF/HTML
#' @export
#'
#' @examples
#'
#' final <- data.frame(
#' label = c(
#' "Overall", "Safety Analysis Set",
#' "Any Adverse event{\\super a}", "- Serious Adverse Event"
#' ),
#' Drug_A = c("", "40", "10 (25%)", "0"),
#' Drug_B = c("", "40", "10 (25%)", "0"),
#' anbr = c(1, 2, 3, 4),
#' roworder = c(1, 1, 1, 1),
#' boldme = c(1, 0, 0, 0),
#' newrows = c(0, 0, 1, 0),
#' indentme = c(0, 0, 0, 1),
#' newpage = c(0, 0, 0, 0)
#' )
#'
#' # Produce output in rtf format
#' gentlg(
#' huxme = final,
#' wcol = c(0.70, 0.15, 0.15),
#' file = "TSFAEX",
#' title = "This is Amazing Demonstration 1",
#' footers = c(
#' "Note: For demonstrative purposes only",
#' "{\\super a} Subjects are counted once for any given event."
#' )
#' )
#'
#' # Pass in column headers instead of using variable name
#' gentlg(
#' huxme = final,
#' wcol = c(0.70, 0.15, 0.15),
#' file = "TSFAEX",
#' colheader = c("", "Drug A", "Drug B"),
#' title = "This is Amazing Demonstration 1",
#' footers = c(
#' "Note: For demonstrative purposes only",
#' "{\\super a} Subjects are counted once for any given event."
#' )
#' )
#'
#' # Add spanning bottom borders under the cells in the second row
#' gentlg(
#' huxme = final,
#' wcol = c(0.70, 0.15, 0.15),
#' file = "TSFAEX",
#' colheader = c("", "Drug A", "Drug B"),
#' title = "This is Amazing Demonstration 1",
#' footers = c(
#' "Note: For demonstrative purposes only",
#' "{\\super a} Subjects are counted once for any given event."
#' ),
#' border_fns = list(spanning_borders(2))
#' )
#'
#' # Use a watermark
#' gentlg(
#' huxme = final,
#' wcol = c(0.70, 0.15, 0.15),
#' file = "TSFAEX",
#' colheader = c("", "Drug A", "Drug B"),
#' title = "This is Amazing Demonstration 1",
#' footers = c(
#' "Note: For demonstrative purposes only",
#' "{\\super a} Subjects are counted once for any given event."
#' ),
#' watermark = "Confidential"
#' )
#'
#' # Produce output in HTML format
#' hux <- gentlg(
#' huxme = final,
#' file = "TSFAEX",
#' colheader = c("", "Drug A", "Drug B"),
#' title = "This is Amazing Demonstration 1",
#' footers = c(
#' "Note: For demonstrative purposes only",
#' "{\\super a} Subjects are counted once for any given event."
#' ),
#' watermark = "Confidential",
#' format = "HTML",
#' print.hux = FALSE
#' )
#'
#' # Export to HTML page
#' huxtable::quick_html(hux, file = "TSFAEX.html", open = FALSE)
#'
#' # clean up.
#' file.remove("TSFAEX.html", "tsfaex.rtf")
#' @references \url{https://github.com/hughjonesd/huxtable}
gentlg <- function(huxme = NULL,
tlf = "Table",
format = "rtf",
colspan = NULL,
idvars = NULL,
plotnames = NULL,
plotwidth = NULL,
plotheight = NULL,
wcol = 0.45,
orientation = "portrait",
opath = ".",
title_file = NULL,
file = NULL,
title = NULL,
footers = NULL,
print.hux = TRUE,
watermark = NULL,
colheader = NULL,
pagenum = FALSE,
bottom_borders = "old_format",
border_fns = list()) {
adjfilename <- stringr::str_replace_all(
stringr::str_to_lower(file),
"(-|_)", ""
)
if (is.null(huxme)) {
ht <- gentlg_single(
huxme = NULL,
tlf = tlf,
format = format,
colspan = colspan,
idvars = idvars,
plotnames = plotnames,
plotwidth = plotwidth,
plotheight = plotheight,
wcol = wcol,
orientation = orientation,
opath = opath,
title_file = title_file,
file = file,
title = title,
footers = footers,
print.hux = print.hux,
watermark = watermark,
colheader = colheader,
pagenum = pagenum,
bottom_borders = bottom_borders,
border_fns = border_fns
)
if (print.hux == FALSE) {
return(ht$ht)
} else if (print.hux == TRUE && is_format_rtf(format)) {
quick_rtf_jnj(
list(ht$ht),
file = paste(file.path(opath, adjfilename), ".rtf", sep = ""),
pagenum = pagenum,
portrait = tolower(orientation) == "portrait",
watermark = list(watermark),
nheader = 1 + ifelse(is.null(ht$colspan), 0, ht$colspan),
tlf = tlf,
)
return(invisible(NULL))
} else if (print.hux == TRUE && toupper(format) == "HTML") {
huxtable::print_html(ht$ht)
return(invisible(NULL))
}
}
if (inherits(huxme, "data.frame") || inherits(huxme, "ggplot")) {
huxme <- list(huxme)
}
# If we leave NULLs in the arguments
# then the mapply won't run, so we
# wrap the NULLs in a list.
# The same goes for scalar arguments that
# can be arrays.
if (!is.list(title)) {
title <- list(title)
}
if (!is.list(footers)) {
footers <- list(footers)
}
if (!is.list(watermark)) {
watermark <- list(watermark)
}
if (!is.list(colheader)) {
colheader <- list(colheader)
}
if (!is.list(bottom_borders)) {
bottom_borders <- list(bottom_borders)
}
assertthat::assert_that(is.list(border_fns))
if (length(border_fns) == 0 ||
(length(border_fns) > 0 && !is.list(border_fns[[1]]))) {
border_fns <- list(border_fns)
}
if (
(is.list(colspan) && length(colspan) > 0 && !is.list(colspan[[1]])) ||
is.null(colspan)
) {
colspan <- list(colspan)
}
hts <- mapply(
function(ht,
colspan,
title,
footers,
watermark,
colheader,
pagenum,
bottom_borders,
border_fns,
index) {
gentlg_single(
huxme = ht,
tlf = tlf,
format = format,
colspan = colspan,
idvars = idvars,
plotnames = plotnames,
plotwidth = plotwidth,
plotheight = plotheight,
wcol = wcol,
orientation = orientation,
opath = opath,
title_file = title_file,
file = file,
title = title,
footers = footers,
print.hux = FALSE,
watermark = watermark,
colheader = colheader,
pagenum = pagenum,
bottom_borders = bottom_borders,
border_fns = border_fns,
index_in_result = index
)
},
huxme,
colspan,
title,
footers,
watermark,
colheader,
pagenum,
bottom_borders,
border_fns,
seq_len(length(huxme)),
SIMPLIFY = FALSE
)
if (print.hux == FALSE) {
return(lapply(hts, function(ht) ht$ht))
} else if (print.hux == TRUE && is_format_rtf(format)) {
quick_rtf_jnj(lapply(hts, function(ht) ht$ht),
file = paste(file.path(opath, adjfilename), ".rtf", sep = ""),
pagenum = pagenum,
portrait = tolower(orientation) == "portrait",
watermark = watermark,
nheader = 1 + as.numeric(lapply(hts, function(ht) length(ht$colspan))),
tlf = tlf,
)
} else if (print.hux == TRUE && toupper(format) == "HTML") {
lapply(hts, huxtable::print_html)
}
}