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