1# Tags --------------------------------------------------------------------
2
3#' @export
4roxy_tag_parse.roxy_tag_inherit <- function(x) tag_inherit(x)
5#' @export
6roxy_tag_rd.roxy_tag_inherit <- function(x, base_path, env) {
7  rd_section_inherit(x$val$source, list(x$val$fields))
8}
9
10#' @export
11roxy_tag_parse.roxy_tag_inheritParams <- function(x) tag_value(x)
12#' @export
13roxy_tag_rd.roxy_tag_inheritParams <- function(x, base_path, env) {
14  rd_section_inherit(x$val, list("params"))
15}
16
17#' @export
18roxy_tag_parse.roxy_tag_inheritDotParams <- function(x) {
19  tag_two_part(x, "source", "args", required = FALSE, markdown = FALSE)
20}
21#' @export
22roxy_tag_rd.roxy_tag_inheritDotParams <- function(x, base_path, env) {
23  rd_section_inherit_dot_params(x$val$source, x$val$args)
24}
25
26#' @export
27roxy_tag_parse.roxy_tag_inheritSection <- function(x) tag_name_description(x)
28#' @export
29roxy_tag_rd.roxy_tag_inheritSection <- function(x, base_path, env) {
30  rd_section_inherit_section(x$val$name, x$val$description)
31}
32
33
34# Fields ------------------------------------------------------------------
35
36# For each unique source, list which fields it inherits from
37rd_section_inherit <- function(source, fields) {
38  stopifnot(is.character(source), is.list(fields))
39  stopifnot(!anyDuplicated(source))
40  stopifnot(length(source) == length(fields))
41
42  rd_section("inherit", list(source = source, fields = fields))
43}
44
45#' @export
46merge.rd_section_inherit <- function(x, y, ...) {
47  stopifnot(identical(class(x), class(y)))
48
49  dedup <- collapse(
50    c(x$value$source, y$value$source),
51    c(x$value$fields, y$value$fields),
52    function(x) Reduce(union, x)
53  )
54
55  rd_section("inherit", list(source = dedup$key, fields = dedup$value))
56}
57
58#' @export
59format.rd_section_inherit <- function(x, ...) NULL
60
61rd_section_inherit_section <- function(source, title) {
62  stopifnot(is.character(source), is.character(title))
63  stopifnot(length(source) == length(title))
64
65  rd_section("inherit_section", list(source = source, title = title))
66}
67
68#' @export
69format.rd_section_inherit_section <- function(x, ...) NULL
70
71#' @export
72merge.rd_section_inherit_section <- function(x, y, ...) {
73  stopifnot(identical(class(x), class(y)))
74  rd_section_inherit_section(c(x$value$source, y$value$source), c(x$value$title, y$value$title))
75}
76
77rd_section_inherit_dot_params <- function(source, args) {
78  stopifnot(is.character(source), is.character(args))
79  stopifnot(length(source) == length(args))
80
81  rd_section("inherit_dot_params", list(source = source, args = args))
82}
83
84#' @export
85format.rd_section_inherit_dot_params <- function(x, ...) NULL
86
87#' @export
88merge.rd_section_inherit_dot_params <- function(x, y, ...) {
89  stopifnot(identical(class(x), class(y)))
90  rd_section_inherit_dot_params(c(x$value$source, y$value$source), c(x$value$args, y$value$args))
91}
92
93
94# Process inheritance -----------------------------------------------------
95
96topics_process_inherit <- function(topics, env) {
97  inherits <- function(type) {
98    function(x) x$inherits_from(type)
99  }
100
101  topics$topo_apply(inherits("return"), inherit_field,
102    roxy_name = "return", rd_name = "value")
103  topics$topo_apply(inherits("title"), inherit_field, "title")
104  topics$topo_apply(inherits("description"), inherit_field, "description")
105  topics$topo_apply(inherits("details"), inherit_field, "details")
106  topics$topo_apply(inherits("seealso"), inherit_field, "seealso")
107  topics$topo_apply(inherits("references"), inherit_field, "references")
108  topics$topo_apply(inherits("examples"), inherit_field, "examples")
109  topics$topo_apply(inherits("author"), inherit_field, "author")
110  topics$topo_apply(inherits("source"), inherit_field, "source")
111
112  # First inherit individual sections, then all sections.
113  topics$topo_apply(function(x) x$inherits_section_from(), inherit_section)
114  topics$topo_apply(inherits("sections"), inherit_sections)
115
116  topics$topo_apply(inherits("params"), inherit_params)
117  # Can't inherit ... into ... so can do in any order
118  topics$apply(inherit_dot_params, env = env)
119
120  invisible()
121}
122
123# Inherit parameters -----------------------------------------------------------
124
125inherit_params <- function(topic, topics) {
126  inheritors <- topic$inherits_from("params")
127  if (length(inheritors) == 0) {
128    return()
129  }
130
131  documented <- get_documented_params(topic)
132  needed <- topic$get_value("formals")
133  missing <- setdiff(needed, documented)
134  if (length(missing) == 0) {
135    warn(paste0(
136      "Topic '", topic$get_name(), "': ",
137      "no parameters to inherit with @inheritParams"
138    ))
139    return()
140  }
141
142  for (inheritor in inheritors) {
143    inherited <- find_params(inheritor, topics)
144
145    matches <- map_chr(missing, match_param, names(inherited))
146    new_match <- !is.na(matches)
147
148    if (!any(new_match)) {
149      # Can't warn here because @inherit inherits parameters
150      next
151    }
152
153    topic$add(
154      rd_section(
155        "param",
156        setNames(inherited[matches[new_match]], missing[new_match])
157      )
158    )
159    missing <- missing[!new_match]
160  }
161}
162
163inherit_dot_params <- function(topic, topics, env) {
164  inheritors <- topic$get_value("inherit_dot_params")
165  if (is.null(inheritors))
166    return()
167
168  # Need to find formals for each source
169  funs <- lapply(inheritors$source, function(x) eval(parse(text = x), envir = env))
170  args <- map2(funs, inheritors$args, select_args_text)
171
172  # Then pull out the ones we need
173  docs <- lapply(inheritors$source, find_params, topics = topics)
174  arg_matches <- function(args, docs) {
175    doc_args <- str_split(names(docs), ", ?")
176    match <- map_lgl(doc_args, function(x) x %in% args)
177    docs[match]
178  }
179  docs_selected <- unlist(map2(args, docs, arg_matches))
180
181  # Only document params under "..." that aren't otherwise documented
182  documented <- get_documented_params(topic)
183  non_documented_params <- setdiff(names(docs_selected), documented)
184  docs_selected <- docs_selected[non_documented_params]
185
186  # Build the Rd
187  # (1) Link to function(s) that was inherited from
188  src <- inheritors$source
189  dest <- map_chr(src, resolve_qualified_link)
190  from <- paste0("\\code{\\link[", dest, "]{", src, "}}", collapse = ", ")
191
192  # (2) Show each inherited argument
193  arg_names <- paste0("\\code{", names(docs_selected), "}")
194  args <- paste0("    \\item{", arg_names, "}{", docs_selected, "}", collapse = "\n")
195
196  rd <- paste0(
197    "\n",
198    "  Arguments passed on to ", from, "\n",
199    "  \\describe{\n",
200    args, "\n",
201    "  }"
202  )
203  topic$add(rd_section("param", c("..." = rd)))
204}
205
206
207get_documented_params <- function(topic, only_first = FALSE) {
208  documented <- names(topic$get_value("param"))
209  if (length(documented) > 0) {
210    documented <- strsplit(documented, ",")
211    if (only_first)
212      documented <- map_chr(documented, 1)
213    else
214      documented <- unlist(documented)
215  }
216
217  documented[documented == "\\dots"] <- "..."
218  documented
219}
220
221find_params <- function(name, topics) {
222  topic <- get_rd(name, topics)
223  if (is.null(topic)) {
224    return()
225  }
226
227  params <- topic_params(topic)
228  if (is.null(params))
229    return()
230
231  param_names <- str_trim(names(params))
232  param_names[param_names == "\\dots"] <- "..."
233
234  # Split up compound names on , (swallowing spaces) duplicating their contents
235  individual_names <- strsplit(param_names, ",\\s*")
236  reps <- map_int(individual_names, length)
237
238  setNames(rep.int(params, reps), unlist(individual_names))
239}
240
241topic_params <- function(x) UseMethod("topic_params")
242topic_params.Rd <- function(x) {
243  arguments <- get_tags(x, "\\arguments")
244  if (length(arguments) != 1) {
245    return(list())
246  }
247  items <- get_tags(arguments[[1]], "\\item")
248
249  values <- map_chr(items, function(x) rd2text(x[[2]]))
250  params <- map_chr(items, function(x) rd2text(x[[1]]))
251
252  setNames(values, params)
253}
254topic_params.RoxyTopic <- function(x) {
255  x$get_value("param")
256}
257
258
259# Inherit sections --------------------------------------------------------
260
261inherit_sections <- function(topic, topics) {
262  current_secs <- topic$get_value("section")$title
263
264  for (inheritor in topic$inherits_from("sections")) {
265    inheritor <- get_rd(inheritor, topics)
266    if (is.null(inheritor)) {
267      return()
268    }
269
270    sections <- find_sections(inheritor)
271    needed <- !(sections$title %in% current_secs)
272    if (!any(needed))
273      next
274
275    topic$add(
276      rd_section_section(sections$title[needed], sections$content[needed])
277    )
278  }
279}
280
281inherit_section <- function(topic, topics) {
282  sections <- topic$get_value("inherit_section")
283  sources <- sections$source
284  titles <- sections$title
285
286  for (i in seq_along(sources)) {
287    inheritor <- get_rd(sources[[i]], topics)
288    if (is.null(inheritor)) {
289      return()
290    }
291
292    new_section <- find_sections(inheritor)
293    selected <- new_section$title %in% titles[[i]]
294
295    if (sum(selected) != 1) {
296      warning(
297        "Can't find section '", titles[[i]], "' in ?",
298        sources[[i]], call. = FALSE
299      )
300    }
301
302    topic$add(
303      rd_section_section(new_section$title[selected], new_section$content[selected])
304    )
305  }
306}
307
308find_sections <- function(topic) {
309  if (inherits(topic, "Rd")) {
310    tag <- get_tags(topic, "\\section")
311
312    titles <- map_chr(map(tag, 1), rd2text)
313    contents <- map_chr(map(tag, 2), rd2text)
314
315    list(title = titles, content = contents)
316  } else {
317    topic$get_value("section")
318  }
319}
320
321
322# Inherit from single field ----------------------------------------------------
323
324inherit_field <- function(topic, topics, rd_name, roxy_name = rd_name) {
325  # Already has the field, so don't need to inherit
326  if (topic$has_section(rd_name))
327    return()
328
329  # Otherwise, try each try function listed in inherits
330  for (inherit_from in topic$inherits_from(roxy_name)) {
331    inherit_topic <- get_rd(inherit_from, topics)
332    if (is.null(inherit_topic)) {
333      next
334    }
335
336    inheritee <- find_field(inherit_topic, rd_name)
337    if (is.null(inheritee))
338      next
339
340    topic$add(rd_section(rd_name, inheritee))
341    return()
342  }
343}
344
345find_field <- function(topic, field_name) {
346  if (inherits(topic, "Rd")) {
347    tag <- get_tags(topic, paste0("\\", field_name))
348    if (length(tag) == 0)
349      return()
350
351    value <- tag[[1]]
352    attr(value, "Rd_tag") <- NULL
353
354    str_trim(rd2text(value))
355  } else {
356    topic$get_value(field_name)
357  }
358}
359
360# Find info in Rd or topic ------------------------------------------------
361
362get_rd <- function(name, topics) {
363  if (has_colons(name)) {
364    # External package
365    parsed <- parse_expr(name)
366    pkg <- as.character(parsed[[2]])
367    fun <- as.character(parsed[[3]])
368
369    tweak_links(get_rd_from_help(pkg, fun), package = pkg)
370  } else {
371    # Current package
372    rd_name <- topics$find_filename(name)
373    if (identical(rd_name, NA_character_)) {
374      warn(paste0("Can't find help topic '", name, "' in current package"))
375    }
376    topics$get(rd_name)
377  }
378}
379
380get_rd_from_help <- function(package, alias) {
381  if (!is_installed(package)) {
382    warn(paste0("Can't find package '", package, "'"))
383    return()
384  }
385
386  help <- eval(expr(help(!!alias, !!package)))
387  if (length(help) == 0) {
388    warn(paste0("Can't find help topic '", alias, "' in '", package, "' package"))
389    return()
390  }
391
392  internal_f("utils", ".getHelpFile")(help)
393}
394
395
396# helpers -----------------------------------------------------------------
397
398# Returns matching parameter name in haystack
399match_param <- function(needle, haystack) {
400  if (needle %in% haystack) {
401    return(needle)
402  }
403
404  if (substr(needle, 1, 1) == ".") {
405    if (needle %in% paste0(".", haystack)) {
406      return(substr(needle, 2, nchar(needle)))
407    }
408  } else {
409    if (paste0(".", needle) %in% haystack) {
410      return(paste0(".", needle))
411    }
412  }
413
414  NA
415}
416
417