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