1
2topic_add_r6_methods <- function(rd, block, env) {
3  r6data <- block_get_tag_value(block, ".r6data")
4  self <- r6data$self
5  methods <- self[self$type == "method", ]
6  methods <- methods[order(methods$file, methods$line), ]
7  methods$tags <- replicate(nrow(methods), list(), simplify = FALSE)
8
9  r6_tags <- c("description", "details", "param", "return", "examples")
10
11  del <- integer()
12  for (i in seq_along(block$tags)) {
13    tag <- block$tags[[i]]
14    # Not inline?
15    if (is.na(tag$line) || tag$line < block$line) next
16    # Not a method tag?
17    if (! tag$tag %in% r6_tags) next
18    del <- c(del, i)
19    meth <- find_method_for_tag(methods, tag)
20    if (is.na(meth)) {
21      roxy_tag_warning(tag, "Cannot find matching R6 method")
22      next
23    }
24    midx <- which(meth == methods$name)
25    methods$tags[[midx]] <- c(methods$tags[[midx]], list(tag))
26    del <- c(del, i)
27  }
28
29  methods <- add_default_methods(methods)
30
31  nodoc <- map_int(methods$tags, length) == 0
32  r6_warning(block, "undocumented R6 method[s]: %s", methods$name[nodoc])
33
34  block$tags[del] <- NULL
35
36  # Now do the main tags first. We leave out the param tags, those are
37  # for the methods
38  for (tag in block$tags) {
39    if (! tag$tag %in% c("param", "field")) {
40      rd$add(roxy_tag_rd(tag, env = env, base_path = base_path))
41    }
42  }
43
44  # We need to add the whole thing as a big section.
45  rd_lines <- c(
46    r6_superclass(block, r6data, env),
47    r6_fields(block, r6data),
48    r6_active_bindings(block, r6data),
49    r6_methods(block, r6data, methods)
50  )
51
52  rd$add(rd_section("rawRd", paste(rd_lines, collapse = "\n")))
53
54  # Dump all method examples at the end of the examples block
55  ex_lines <- r6_all_examples(block, methods)
56  if (length(ex_lines) > 0) {
57    ex_txt <- paste0(r6_all_examples(block, methods), collapse = "\n")
58    rd$add(rd_section("examples", ex_txt), overwrite = FALSE)
59  }
60}
61
62add_default_methods <- function(methods) {
63  defaults <- list(
64    clone = list(
65      roxy_tag_parse(roxy_tag(
66        "description",
67        "The objects of this class are cloneable with this method."
68      )),
69      roxy_tag_parse(roxy_tag("param", "deep Whether to make a deep clone."))
70    )
71  )
72
73  for (mname in names(defaults)) {
74    mline <- match(mname, methods$name)
75    if (is.na(mline)) next
76    if (length(methods$tags[[mline]]) > 0) next
77    methods$tags[[mline]] <- defaults[[mname]]
78  }
79
80  methods
81}
82
83r6_superclass <- function(block, r6data, env) {
84  super <- r6data$super
85  cls <- unique(super$classes$classname)
86  if (length(cls) == 0) return()
87
88  lines <- character()
89  push <- function(...) lines <<- c(lines, ...)
90
91  title <- if (length(cls) > 1) "Super classes" else "Super class"
92  push(paste0("\\section{", title, "}{"))
93
94  pkgs <- super$classes$package[match(cls, super$classes$classname)]
95  path <- sprintf("\\code{\\link[%s:%s]{%s::%s}}", pkgs, cls, pkgs, cls)
96  me <- sprintf("\\code{%s}", block$object$value$classname)
97  push(paste(c(rev(path), me), collapse = " -> "))
98
99  push("}")
100
101  lines
102}
103
104r6_fields <- function(block, r6data) {
105  self <- r6data$self
106  fields <- self$name[self$type == "field"]
107  active <- self$name[self$type == "active"]
108
109  tags <- purrr::keep(
110    block$tags,
111    function(t) t$tag == "field" && ! t$val$name %in% active
112  )
113
114  labels <- gsub(",", ", ", map_chr(tags, c("val", "name")))
115  docd <- str_trim(unlist(strsplit(labels, ",")))
116
117  # Check for missing fields
118  miss <- setdiff(fields, docd)
119  r6_warning(block, "undocumented R6 field[s]: %s", miss)
120
121  # Check for duplicate fields
122  dup <- unique(docd[duplicated(docd)])
123  r6_warning(block, "R6 field[s] documented multiple times: %s", dup)
124
125  # Check for extra fields
126  xtra <- setdiff(docd, fields)
127  r6_warning(block, "unknown R6 field[s]: %s", xtra)
128
129  if (length(docd) == 0) return()
130
131  # We keep the order of the documentation
132
133  vals <- map_chr(tags, c("val", "description"))
134  c("\\section{Public fields}{",
135    "\\if{html}{\\out{<div class=\"r6-fields\">}}",
136    "\\describe{",
137    paste0("\\item{\\code{", labels, "}}{", vals, "}", collapse = "\n\n"),
138    "}",
139    "\\if{html}{\\out{</div>}}",
140    "}"
141  )
142}
143
144r6_active_bindings <- function(block, r6data) {
145  self <- r6data$self
146  fields <- self$name[self$type == "field"]
147  active <- self$name[self$type == "active"]
148
149  tags <- purrr::keep(
150    block$tags,
151    function(t) t$tag == "field" && ! t$val$name %in% fields
152  )
153
154  labels <- gsub(",", ", ", map_chr(tags, c("val", "name")))
155  docd <- str_trim(unlist(strsplit(labels, ",")))
156
157  # Check for missing bindings
158  miss <- setdiff(active, docd)
159  r6_warning(block, "undocumented R6 active binding[s]: %s", miss)
160
161  # Check for duplicate bindings
162  dup <- unique(docd[duplicated(docd)])
163  r6_warning(block, "R6 active binding[s] documented multiple times: %s", dup)
164
165  if (length(docd) == 0) return()
166
167  # We keep the order of the documentation
168
169  vals <- map_chr(tags, c("val", "description"))
170  c("\\section{Active bindings}{",
171    "\\if{html}{\\out{<div class=\"r6-active-bindings\">}}",
172    "\\describe{",
173    paste0("\\item{\\code{", labels, "}}{", vals, "}", collapse = "\n\n"),
174    "}",
175    "\\if{html}{\\out{</div>}}",
176    "}"
177  )
178}
179
180r6_methods <- function(block, r6data, methods) {
181  # And then the methods, if any
182  if (nrow(methods) == 0) return()
183
184  lines <- character()
185  push <- function(...) lines <<- c(lines, ...)
186
187  push("\\section{Methods}{")
188  push(r6_method_list(block, methods))
189  push(r6_inherited_method_list(block, r6data))
190  for (i in seq_len(nrow(methods))) {
191    push(r6_method_begin(block, methods[i,]))
192    push(r6_method_description(block, methods[i,]))
193    push(r6_method_usage(block, methods[i,]))
194    push(r6_method_params(block, methods[i,]))
195    push(r6_method_details(block, methods[i,]))
196    push(r6_method_return(block, methods[i,]))
197    push(r6_method_examples(block, methods[i,]))
198    push(r6_method_end(block, methods[i,]))
199  }
200  push("}")
201
202  lines
203}
204
205find_method_for_tag <- function(methods, tag) {
206  w <- which(
207    basename(methods$file) == basename(tag$file) &
208    methods$line > tag$line
209  )[1]
210  methods$name[w]
211}
212
213# vectorized
214
215r6_show_name <- function(names) {
216  ifelse(names == "initialize", "new", names)
217}
218
219r6_method_list <- function(block, methods) {
220  nms <- r6_show_name(methods$name)
221  c("\\subsection{Public methods}{",
222    "\\itemize{",
223    sprintf(
224      "\\item \\href{#method-%s}{\\code{%s$%s()}}",
225      nms,
226      block$object$alias,
227      nms
228    ),
229    "}",
230    "}"
231  )
232}
233
234r6_inherited_method_list <- function(block, r6data) {
235  super <- r6data$super
236  if (is.null(super)) return()
237
238  # drop methods that were shadowed in a subclass
239  super_meth <- super$members[super$members$type == "method", ]
240  self <- r6data$self
241  super_meth <- super_meth[! super_meth$name %in% self$name, ]
242  super_meth <- super_meth[! duplicated(super_meth$name), ]
243
244  super_meth <- super_meth[rev(seq_len(nrow(super_meth))), ]
245
246  details <- paste0(
247    "<details ",
248    if (nrow(super_meth) <= 5) "open ",
249    "><summary>Inherited methods</summary>"
250  )
251
252  c("\\if{html}{",
253    paste0("\\out{", details, "}"),
254    "\\itemize{",
255    sprintf(
256      paste0(
257        "\\item \\out{<span class=\"pkg-link\" data-pkg=\"%s\" ",
258        "data-topic=\"%s\" data-id=\"%s\">}",
259        "\\href{../../%s/html/%s.html#method-%s}{\\code{%s::%s$%s()}}",
260        "\\out{</span>}"
261      ),
262      super_meth$package,
263      super_meth$classname,
264      super_meth$name,
265      super_meth$package,
266      super_meth$classname,
267      super_meth$name,
268      super_meth$package,
269      super_meth$classname,
270      super_meth$name
271    ),
272    "}",
273    "\\out{</details>}",
274    "}"
275  )
276}
277
278r6_method_begin <- function(block, method) {
279  nm <- r6_show_name(method$name)
280  c(
281    "\\if{html}{\\out{<hr>}}",
282    paste0("\\if{html}{\\out{<a id=\"method-", nm, "\"></a>}}"),
283    paste0("\\if{latex}{\\out{\\hypertarget{method-", nm, "}{}}}"),
284    paste0("\\subsection{Method \\code{", nm, "()}}{")
285  )
286}
287
288r6_method_description <- function(block, method) {
289  det <- purrr::keep(method$tags[[1]], function(t) t$tag == "description")
290  # Add an empty line between @description tags, if there isn't one
291  # there already
292  txt <- map_chr(det, "val")
293  c(
294    sub("\n?\n?$", "\n\n", head(txt, -1)),
295    utils::tail(txt, 1)
296  )
297}
298
299r6_method_usage <- function(block, method) {
300  name <- paste0(block$object$alias, "$", r6_show_name(method$name))
301  fake <- paste(rep("X", nchar(name)), collapse = "")
302  usage <- format(function_usage(fake, method$formals[[1]]))
303  c(
304    "\\subsection{Usage}{",
305    paste0(
306      "\\if{html}{\\out{<div class=\"r\">}}",
307      "\\preformatted{", sub(paste0("^", fake), name, usage),
308      "}",
309      "\\if{html}{\\out{</div>}}"
310    ),
311    "}\n"
312  )
313}
314
315r6_method_details <- function(block, method) {
316  det <- purrr::keep(method$tags[[1]], function(t) t$tag == "details")
317  # Add an empty line between @details tags, if there isn't one
318  # there already
319  txt <- map_chr(det, "val")
320  if (length(txt) == 0) return()
321  c(
322    "\\subsection{Details}{",
323    sub("\n?\n?$", "\n\n", head(txt, -1)),
324    utils::tail(txt, 1),
325    "}\n"
326  )
327}
328
329r6_method_params <- function(block, method) {
330  par <- purrr::keep(method$tags[[1]], function(t) t$tag == "param")
331  nms <- gsub(",", ", ", map_chr(par, c("val", "name")))
332
333  # Each arg should appear exactly once
334  mnames <- str_trim(unlist(strsplit(nms, ",")))
335  dup <- unique(mnames[duplicated(mnames)])
336  for (m in dup) {
337    roxy_warning(
338      sprintf("argument `%s` documented multiple times for R6 method `%s`", m, method$name),
339      file = block$file, line = method$line
340    )
341  }
342
343  # Now add the missing ones from the class
344  fnames <- names(method$formals[[1]])
345  miss <- setdiff(fnames, mnames)
346  is_in_cls <- map_lgl(
347    block$tags,
348    function(t) {
349      !is.na(t$line) && t$line < block$line && t$tag == "param" &&
350        t$val$name %in% miss
351    }
352  )
353  par <- c(par, block$tags[is_in_cls])
354
355  # Check if anything is missing
356  nms <- gsub(",", ", ", map_chr(par, c("val", "name")))
357  mnames <- str_trim(unlist(strsplit(nms, ",")))
358  miss <- setdiff(fnames, mnames)
359  for (m in miss) {
360    roxy_warning(
361      sprintf("argument `%s` undocumented for R6 method `%s()`", m, method$name),
362      file = block$file, line = method$line
363    )
364  }
365
366  if (length(par) == 0) return()
367
368  # Order them according to formals
369  firstnames <- str_trim(
370    map_chr(strsplit(map_chr(par, c("val", "name")), ","), 1)
371  )
372  par <- par[order(match(firstnames, fnames))]
373
374  val <- map_chr(par, c("val", "description"))
375  nms <- gsub(",", ", ", map_chr(par, c("val", "name")))
376
377  # Ready to go
378  c(
379    "\\subsection{Arguments}{",
380    "\\if{html}{\\out{<div class=\"arguments\">}}",
381    "\\describe{",
382    paste0("\\item{\\code{", nms, "}}{", val, "}", collapse = "\n\n"),
383    "}",
384    "\\if{html}{\\out{</div>}}",
385    "}"
386  )
387}
388
389r6_method_return <- function(block, method) {
390  ret <- purrr::keep(method$tags[[1]], function(t) t$tag == "return")
391  if (length(ret) == 0) return()
392  if (length(ret) > 1) {
393    roxy_tag_warning(ret[[2]], "May only use one @return per R6 method")
394  }
395  ret <- ret[[1]]
396  c(
397    "\\subsection{Returns}{",
398    ret$val,
399    "}"
400  )
401}
402
403r6_method_examples <- function(block, method) {
404  exa <- purrr::keep(method$tags[[1]], function(t) t$tag == "examples")
405  if (length(exa) == 0) return()
406
407  txt <- map_chr(exa, "val")
408
409  c("\\subsection{Examples}{",
410    paste0(
411      "\\if{html}{\\out{<div class=\"r example copy\">}}\n",
412      "\\preformatted{", txt, "\n",
413      "}\n",
414      "\\if{html}{\\out{</div>}}\n",
415      collapse = "\n"
416    ),
417    "}\n"
418  )
419}
420
421r6_method_end <- function(block, method) {
422  c(
423    "}"
424  )
425}
426
427r6_all_examples <- function(block, methods) {
428  unlist(lapply(
429    seq_len(nrow(methods)),
430    function(i) {
431      exa <- purrr::keep(methods$tags[[i]], function(t) t$tag == "examples")
432      if (length(exa) == 0) return()
433      name <- paste0(block$object$alias, "$", r6_show_name(methods$name[i]))
434      c(
435        "\n## ------------------------------------------------",
436        paste0("## Method `", name, "`"),
437        "## ------------------------------------------------\n",
438        paste(map_chr(exa, "val"), collapse = "\n")
439      )
440  }))
441}
442
443first_five <- function(x) {
444  x <- encodeString(x, quote = "`")
445  if (length(x) > 5) x <- c(x[1:5], "...")
446  paste(x, collapse = ", ")
447}
448
449r6_warning <- function(block, template, bad) {
450  if (length(bad) == 0) return()
451  badlist <- first_five(bad)
452  template <- gsub("[s]", if (length(bad) == 1) "" else "s", template, fixed = TRUE)
453  roxy_warning(sprintf(template, badlist), file = block$file, line = block$line)
454}
455