1#' @export
2roxy_tag_parse.roxy_tag_usage <- function(x) {
3  x <- tag_value(x)
4  x$val <- rd(x$val)
5  x
6}
7
8#' @export
9roxy_tag_rd.roxy_tag_usage <- function(x, base_path, env) {
10  if (identical(x$val, rd("NULL"))) {
11    usage <- NULL
12  } else {
13    usage <- x$val
14  }
15  rd_section("usage", usage)
16}
17
18#' @export
19format.rd_section_usage <- function(x, ...) {
20  rd_macro(x$type, build_rd(x$value, collapse = "\n\n"), space = TRUE)
21}
22
23# object_usage ------------------------------------------------------------
24
25object_usage <- function(x) {
26  UseMethod("object_usage")
27}
28
29object_usage.default <- function(x) {
30  NULL
31}
32
33object_usage.data <- function(x) {
34  rd(x$alias)
35}
36
37object_usage.function <- function(x) {
38  function_usage(x$alias, formals(x$value), identity)
39}
40
41object_usage.s3generic <- object_usage.function
42
43object_usage.s3method <- function(x) {
44  method <- attr(x$value, "s3method")
45  s3method <- function(name) {
46    paste0("\\method{", name, "}{", auto_backtick(method[2]), "}")
47  }
48  function_usage(method[1], formals(x$value), s3method)
49}
50
51object_usage.s4generic <- function(x) {
52  function_usage(x$value@generic, formals(x$value), identity)
53}
54
55object_usage.s4method <- function(x) {
56  s4method <- function(name) {
57    classes <- auto_backtick(as.character(x$value@defined))
58    paste0("\\S4method{", name, "}{", paste0(classes, collapse = ","), "}")
59  }
60  function_usage(x$value@generic, formals(x$value), s4method)
61}
62
63# Function usage ----------------------------------------------------------
64
65# Usage:
66# replacement, infix, regular
67# function, s3 method, s4 method, data
68
69function_usage <- function(name, formals, format_name = identity) {
70  if (is_replacement_fun(name) && !is_infix_fun(name)) {
71    name <- str_replace(name, fixed("<-"), "")
72    if (identical(format_name, identity)) {
73      name <- auto_backtick(name)
74    }
75    name <- gsub("%", "\\%", name, fixed = TRUE)
76    formals$value <- NULL
77
78    wrap_usage(name, format_name, formals, suffix = " <- value")
79  } else if (is_infix_fun(name) && identical(format_name, identity)) {
80    # If infix, and regular function, munge format
81    arg_names <- names(formals)
82    build_rd(arg_names[1], " ", format_name(name), " ", arg_names[2])
83  } else {
84    if (identical(format_name, identity)) {
85      name <- auto_backtick(name)
86    }
87    name <- gsub("%", "\\%", name, fixed = TRUE)
88    wrap_usage(name, format_name, formals)
89  }
90}
91
92is_replacement_fun <- function(name) {
93  str_detect(name, fixed("<-"))
94}
95is_infix_fun <- function(name) {
96  str_detect(name, "^%.*%$")
97}
98
99usage_args <- function(args) {
100  is.missing.arg <- function(arg) {
101    is.symbol(arg) && deparse(arg) == ""
102  }
103  arg_to_text <- function(arg) {
104    if (is.missing.arg(arg)) return("")
105    text <- enc2utf8(deparse(arg, backtick = TRUE, width.cutoff = 500L))
106    text <- paste0(text, collapse = "\n")
107    Encoding(text) <- "UTF-8"
108
109    text
110  }
111  map_chr(args, arg_to_text)
112}
113
114args_string <- function(x) {
115  sep <- ifelse(x != "", "\u{A0}=\u{A0}", "")
116  arg_names <- escape(auto_backtick(names(x)))
117  paste0(arg_names, sep, escape(x))
118}
119
120args_call <- function(call, args) {
121  paste0(call, "(", paste0(args, collapse = ", "), ")")
122}
123
124#' @param name Function name
125#' @param format_name Single argument that returns formatted function name
126#' @param formals List of function formals
127#' @param suffix Optional suffix, used for replacement functions
128#' @noRd
129wrap_usage <- function(name, format_name, formals, suffix = NULL, width = 80L) {
130  args <- args_string(usage_args(formals))
131
132  # Do we need any wrapping?
133  bare <- args_call(name, args)
134  if (nchar(bare, type = "width") < width) {
135    out <- args_call(format_name(name), args)
136  } else if (roxy_meta_get("old_usage", FALSE)) {
137    x <- args_call(format_name(name), args)
138    out <- wrapUsage(x, width = as.integer(width))
139  } else {
140    args <- paste0("  ", args)
141    args <- map_chr(args, wrapUsage, width = 90, indent = 4)
142    out <- paste0(format_name(name), "(\n", paste0(args, collapse = ",\n"), "\n)")
143  }
144
145  out <- gsub("\u{A0}", " ", out, useBytes = TRUE)
146  Encoding(out) <- "UTF-8"
147
148  rd(paste0(out, suffix))
149}
150
151# helpers -----------------------------------------------------------------
152
153# used for testing
154call_to_usage <- function(code, env = pkg_env()) {
155  obj <- call_to_object(!!enexpr(code), env)
156  gsub("\u{A0}", " ", as.character(object_usage(obj)))
157}
158