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
|
# the code below was mostly contributed by @egnha from
# https://github.com/yihui/formatR/pull/66
deparse_collapse = function(x) {
d = deparse(x)
if (length(d) > 1L) {
paste(trimws(d, which = 'both'), collapse = ' ')
} else {
d
}
}
count_tokens = function(.call) {
if (length(.call) == 1L) {
# +2 for '()'
return(nchar(.call) + 2L)
}
# +1 for value-delimiting '(', ',', or ')'
cnt_val = nchar(vapply(.call, deparse_collapse, character(1L))) + 1L
nms = names(.call[-1L])
if (is.null(nms)) nms = character(length(.call[-1L]))
# nchar() of argument names
cnt_nm = nchar(nms)
# +3 for ' = ', for argument-value pairs
cnt_nm[cnt_nm != 0L] = cnt_nm[cnt_nm != 0L] + 3L
# +1 for space before name, beyond the first argument
cnt_nm[-1L] = cnt_nm[-1L] + 1L
# function itself is not a named component
cnt_nm = c(0L, cnt_nm)
cumsum(cnt_val + cnt_nm)
}
# counts is a strictly increasing, positive integer vector
find_breaks = function(counts, width, indent, track, counted = 0L) {
if (!length(counts)) {
return(list(breaks = NULL, overflow = NULL))
}
overflow = NULL
shift = if (counted == 0L) 0L else indent
fits = counts - counted + shift <= width
i = which.min(fits) - 1L
if (i == 0L) {
if (fits[[1L]]) {
# all components of fits_on_line are TRUE
i = length(counts)
} else {
# all components of fits_on_line are FALSE
overflow = track(counted, counts[1L], shift)
i = 1L
}
}
post_space = if (i == 1L && counted == 0L) 0L else 1L
rest = Recall(counts[-(1L:i)], width, indent, track, counts[i] + post_space)
list(
breaks = c(counts[i], rest$breaks),
overflow = c(overflow, rest$overflow)
)
}
overflow_message = function(overflow, width, indent, text) {
header = sprintf('Could not fit all lines to width %s (with indent %s):',
width, indent)
idxs = seq_along(overflow)
args = vapply(idxs[idxs %% 3L == 1L], function(i) {
l = paste(c(rep(' ', overflow[i + 2L]),
trimws(substr(text, overflow[i] + 1L, overflow[i + 1L]),
which = 'left')),
collapse = '')
sprintf('(%s) \"%s\"', nchar(l), l)
}, character(1L))
one_string(c(header, args))
}
tidy_usage = function(nm, usg, width, indent, fail) {
text = paste(trimws(usg, which = 'both'), collapse = ' ')
text = sub(sprintf('^%s\\s*', nm), nm, text)
expr = parse(text = text)[[1L]]
track_overflow = if (fail == 'none') function(...) NULL else base::c
breaks = find_breaks(count_tokens(expr), width, indent, track_overflow)
if (length(breaks$overflow)) {
signal = switch(fail, stop = 'stop', warn = 'warning')
msg = overflow_message(breaks$overflow, width, indent, text)
getFromNamespace(signal, 'base')(msg, call. = FALSE)
}
breaks = c(0L, breaks$breaks)
newline = paste(c('\n', character(indent)), collapse = ' ')
paste(
vapply(1L:(length(breaks) - 1L), function(i) {
trimws(substr(text, breaks[i] + 1L, breaks[i + 1L]), which = 'left')
}, character(1L)),
collapse = newline
)
}
#' Show the usage of a function
#'
#' Print the reformatted usage of a function. The arguments of the function are
#' searched by \code{\link{argsAnywhere}()}, so the function can be either
#' exported or non-exported from a package. S3 methods will be marked.
#' @param FUN The function name.
#' @param width The width of the output.
#' @param tidy Whether to reformat the usage code.
#' @param output Whether to print the output to the console (via
#' \code{\link{cat}()}).
#' @param indent.by.FUN Whether to indent subsequent lines by the width of the
#' function name (see \dQuote{Details}).
#' @param fail A character string that represents the action taken when the
#' width constraint is unfulfillable. "warn" and "stop" will signal warnings
#' and errors, while "none" will do nothing.
#' @return Reformatted usage code of a function, in character strings
#' (invisible).
#' @details Line breaks in the output occur between arguments. In particular,
#' default values of arguments will not be split across lines.
#'
#' When \code{indent.by.FUN} is \code{FALSE}, indentation is set by the option
#' \code{\link{getOption}("formatR.indent", 4L)}, the default value of the
#' \code{indent} argument of \code{\link{tidy_source}()}.
#' @seealso \code{\link{tidy_source}()}
#' @export
#' @examples library(formatR)
#' usage(var)
#'
#' usage(plot)
#'
#' usage(plot.default) # default method
#' usage('plot.lm') # on the 'lm' class
#'
#' usage(usage)
#'
#' usage(barplot.default, width = 60) # output lines have 60 characters or less
#'
#' # indent by width of 'barplot('
#' usage(barplot.default, width = 60, indent.by.FUN = TRUE)
#'
#' \dontrun{
#' # a warning is raised because the width constraint is unfulfillable
#' usage(barplot.default, width = 30)
#' }
usage = function(FUN, width = getOption('width'), tidy = TRUE, output = TRUE,
indent.by.FUN = FALSE, fail = c('warn', 'stop', 'none')) {
fail = match.arg(fail)
fn = as.character(substitute(FUN))
res = capture.output(if (is.function(FUN)) args(FUN) else {
do.call(argsAnywhere, list(fn))
})
if (identical(res, 'NULL')) return()
res[1] = substring(res[1], 9) # rm 'function ' in the beginning
isS3 = FALSE
if (length(fn) == 3 && (fn[1] %in% c('::', ':::'))) fn = fn[3]
if (grepl('.', fn, fixed = TRUE)) {
n = length(parts <- strsplit(fn, '.', fixed = TRUE)[[1]])
for (i in 2:n) {
gen = paste(parts[1L:(i - 1)], collapse = ".")
cl = paste(parts[i:n], collapse = ".")
if (gen == "" || cl == "") next
if (!is.null(f <- getS3method(gen, cl, TRUE)) && !is.null(environment(f))) {
res[1] = paste(gen, res[1])
header = if (cl == 'default')
'## Default S3 method:' else sprintf("## S3 method for class '%s'", cl)
res = c(header, res)
isS3 = TRUE
break
}
}
}
if (!isS3) res[1] = paste(fn, res[1])
if ((n <- length(res)) > 1 && res[n] == 'NULL') res = res[-n] # rm last element 'NULL'
if (!tidy) {
if (output) cat(res, sep = '\n')
return(invisible(res))
}
nm = if (isS3) gen else fn
usg = if (isS3) res[-1L] else res
indent = if (indent.by.FUN) {
# +1 for '('
nchar(nm) + 1L
} else {
# Default indent for tidy_source()
getOption('formatR.indent', 4L)
}
out = tidy_usage(nm, usg, width, indent, fail)
if (isS3) out = c(res[1L], out)
if (output) cat(out, sep = '\n')
invisible(out)
}
|
