1# File src/library/methods/R/promptClass.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2014 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19promptClass <- 20function (clName, filename = NULL, type = "class", 21 keywords = "classes", where = topenv(parent.frame()), 22 generatorName = clName) 23{ 24 classInSig <- function(g, where, cl) { 25 ## given a generic g, is class cl in one of the method 26 ## signatures for the class? 27 cl %in% unique(unlist(findMethods(g, where)@signatures)) 28 } 29 genWithClass <- function(cl, where) { 30 ## given a class cl 31 ## obtain list of all generics with cl in 32 ## one of its signatures 33 allgen <- getGenerics(where = where) 34 ok <- as.logical(unlist(lapply(allgen, classInSig, cl = cl, where = where))) 35 allgen[ok] 36 } 37 38 sigsList <- function (g, where) 39 ## given a generic g, obtain list with one element per signature, 40 ## with argument names inserted 41 { 42 methods <- findMethods(g, where) 43 value <- methods@signatures 44 args <- methods@arguments 45 if(length(value)) { 46 ## name the individual signature elements for output 47 length(args) <- length(value[[1]]) # all sigs are same length 48 value <- lapply(value, function(x){names(x) <- args; x}) 49 } 50 value 51 } 52 slotClassWithSource <- function(clname) { 53 clDef <- getClassDef(clname) 54 extds <- names(clDef@contains) 55 allslots <- getSlots(clDef) ## establishes all slots, in the right order 56 for(j in rev(seq_along(extds))) { 57 i <- extds[[j]] 58 slotsi <- getSlots(getClass(i)) 59 if(length(slotsi)) 60 allslots[names(slotsi)] <- paste0("\"", as.character(slotsi), 61 "\", from class \"", i, "\"") 62 } 63 slotsi <- getSlots(clDef) 64 if(length(slotsi)) 65 allslots[names(slotsi)] <- paste0("\"", as.character(slotsi),"\"") 66 allslots 67 } 68 cleanPrompt <- function(object, name) { 69 ## get the prompt() result and clean out the junk 70 ## lines that prompt() creates 71 value <- utils::prompt(object, name = name, filename = NA) 72 for(i in seq_along(value)) { 73 item <- value[[i]] 74 bad <- grepl("^ *%", item) 75 if(any(bad)) 76 value[[i]] <- item[!bad] 77 } 78 value 79 } 80 pastePar <- function(x) { 81 xn <- names(x) 82 x <- as.character(x) 83 xn <- if(length(xn) == length(x)) paste(xn, "= ") else "" 84 paste0("(", paste0(xn, "\"", x, "\"", collapse = ", "), ")") 85 } 86 escape <- function(txt) gsub("%", "\\%", txt, fixed=TRUE) 87 88 if(is.null(filename)) 89 filename <- paste0(utils:::topicName(type, clName), ".Rd") 90 if(!missing(where) && !is.na(match(clName, getClasses(where)))) 91 whereClass <- where 92 else { 93 whereClass <- utils::find(classMetaName(clName)) 94 if(length(whereClass) == 0L) 95 stop(gettextf("no definition of class %s found", 96 dQuote(clName)), domain = NA) 97 else if(length(whereClass) > 1L) { 98 if(identical(where, topenv(parent.frame()))) { 99 whereClass <- whereClass[[1L]] 100 warning(gettextf("multiple definitions of %s found; using the one on %s", 101 dQuote(clName), whereClass), domain = NA) 102 } 103 else { 104 if(exists(classMetaName(clName), where, inherits = FALSE)) 105 whereClass <- where 106 else 107 stop(sprintf(ngettext(length(whereClass), 108 "no definition of class %s in the specified position, %s, definition on : %s", 109 "no definition of class %s in the specified position, %s, definitions on : %s"), 110 dQuote(clName), where, 111 paste(whereClass, collapse = ", ")), 112 domain = NA) 113 } 114 } 115 } 116 fullName <- utils:::topicName("class", clName) 117 clDef <- getClass(clName, where = whereClass) 118 .name <- paste0("\\name{", fullName, "}") 119 .type <- paste0("\\docType{", type, "}") 120 .alias <- paste0("\\alias{", fullName, "}") 121 .title <- sprintf("\\title{Class \\code{\"%s\"}}", clName) 122 .desc <- paste0("\\description{", 123 "\n%% ~~ A concise (1-5 lines) description of what the class is. ~~", 124 "\n}") 125 slotclasses <- getSlots(clDef) 126 slotnames <- names(slotclasses) 127 slotclasses <- as.character(slotclasses) 128 nslots <- length(slotclasses) 129 clNameQ <- paste0('"', clName, '"') 130 .usage <- "\\section{Objects from the Class}" 131 virtualClass <- isVirtualClass(clName) 132 if(virtualClass) { 133 .usage <- paste0(.usage, "{A virtual Class: No objects may be created from it.}") 134 generator <- NULL # regardless of what exists 135 } 136 else { 137 if(exists(generatorName, where, inherits = FALSE)) 138 generator <- get(generatorName, where, inherits = FALSE) 139 else 140 generator <- NULL 141 if(is(generator, "classGeneratorFunction")) { 142 promptGenerator <- cleanPrompt(generator, generatorName) 143 callString <- .makeCallString(generator, generatorName) 144 .alias <- c(.alias, promptGenerator$aliases) 145 ## the rest of the promptGenerator will be added later 146 } 147 else { 148 initMethod <- unRematchDefinition(selectMethod("initialize", clName)) 149 argNames <- formalArgs(initMethod) 150 ## but for new() the first argument is the class name 151 argNames[[1L]] <- clNameQ 152 callString <- .makeCallString(initMethod, "new", argNames) 153 } 154 .usage <- 155 c(paste0(.usage,"{"), 156 paste0("Objects can be created by calls of the form \\code{", 157 callString, 158 "}."), 159 "%% ~~ describe objects here ~~ ", 160 "}") 161 } 162 .slots <- if (nslots > 0) { 163 slotclasses <- slotClassWithSource(clName) 164 slotnames <- names(slotclasses) 165 .slots.head <- c("\\section{Slots}{", " \\describe{") 166 .slots.body <- paste0(" \\item{\\code{", slotnames, 167 "}:}", "{Object of class \\code{", 168 slotclasses, "} ~~ }") 169 .slots.tail <- c(" }","}") 170 c(.slots.head, .slots.body, .slots.tail) 171 } else character() 172 .extends <- clDef@contains 173## FIXME: the superclass slots should be marked as such 174## and left *optional* to be documented 175 if(length(.extends)) { 176 .extends <- showExtends(.extends, printTo = FALSE) 177 .extends <- 178 c("\\section{Extends}{", 179 paste0("Class \\code{\"\\linkS4class{", 180 .extends$what, 181 "}\"}, ", 182 ## Add Rd markup to 'by class "CLASS"' results 183 gsub("^(by class) (\".*\")$", "\\1 \\\\code{\\2}", 184 .extends$how), 185 "."), 186 "}") 187 } 188 else 189 .extends <- character() 190 nmeths <- length(methnms <- genWithClass(clName, where = whereClass)) 191 .meths.head <- "\\section{Methods}{" 192 .methAliases <- "" 193 if (nmeths > 0) { 194 .meths.body <- " \\describe{" 195 for (i in 1L:nmeths) { 196 .sig <- sigsList(methnms[i], where = whereClass) 197 for (j in seq_along(.sig)) { 198 if (!all(is.na(match(.sig[[j]],clName)))) { 199 methn.i <- escape(methnms[i]) 200 .meths.body <- 201 c(.meths.body, 202 paste0(" \\item{", 203 methn.i, "}{\\code{signature", 204 pastePar(.sig[[j]]), "}: ... }")) 205 206 cur <- paste(.sig[[j]], collapse = ",") 207 .methAliases <- paste0(.methAliases, "\\alias{", 208 methn.i, ",", cur, "-method}\n") 209 } 210 } 211 } 212 .meths.body <- c(.meths.body, " }") 213 } 214 else { 215 .meths.head <- "\\section{Methods}{" 216 .meths.body <- paste("No methods defined with class", clNameQ, 217 "in the signature.") 218 } 219 .meths.tail <- "}" 220 .keywords <- paste0("\\keyword{", keywords, "}") 221 222 Rdtxt <- 223 list(name = .name, 224 version = "\\Rdversion{1.1}", 225 type = .type, 226 aliases = .alias, 227 methAliases = .methAliases, 228 title = .title, 229 description = .desc, 230 "section{Objects from the Class}" = .usage, 231 "section{Slots}" = .slots, 232 "section{Extends}" = .extends, 233 "section{Methods}" = 234 c(.meths.head, .meths.body, .meths.tail), 235 references = paste("\\references{\n%% ~~put references to the", 236 "literature/web site here~~\n}"), 237 author = "\\author{\n%% ~~who you are~~\n}", 238 note = 239 c("\\note{\n%% ~~further notes~~\n}", 240 "", 241 paste("%% ~Make other sections like Warning with", 242 "\\section{Warning }{....} ~"), 243 ""), 244 seealso = 245 c("\\seealso{", 246 paste("%% ~~objects to See Also as", 247 "\\code{\\link{~~fun~~}}, ~~~"), 248 paste("%% ~~or \\code{\\linkS4class{CLASSNAME}}", 249 "for links to other classes ~~~"), 250 "}"), 251 examples = c("\\examples{", 252 paste0("showClass(", clNameQ, ")"), 253 "}"), 254 keywords = .keywords) 255 256 if(is(clDef, "refClassRepresentation")) 257 Rdtxt <- refClassPrompt(clDef, Rdtxt, nmeths, nslots, .meths.head) 258 else if(is(generator, "classGeneratorFunction")) { 259 ## add in the actual usage, arguments sections, mostly to make 260 ## CMD check happy 261 what <- c("usage", "arguments") 262 Rdtxt[what] <- promptGenerator[what] 263 } 264 265 if(is.na(filename)) return(Rdtxt) 266 267 cat(unlist(Rdtxt), file = filename, sep = "\n") 268 .message("A shell of class documentation has been written", 269 .fileDesc(filename), ".\n") 270 invisible(filename) 271} 272 273## used in promptClass() above and in promptMethods() : 274.fileDesc <- function(file) { 275 if(is.character(file)) { 276 if(nzchar(file)) 277 paste(" to the file", sQuote(file)) 278 else 279 " to the standard output connection" 280 } 281 else if(inherits(file, "connection")) 282 paste(" to the connection", 283 sQuote(summary(file)$description)) 284 else "" # what, indeed? 285} 286 287refClassPrompt <- function(clDef, Rdtxt, nmeths, nslots, .meths.head) { 288 ## exclude some sections that are usually irrelevant 289 sections <- names(Rdtxt) 290 envRefX <- paste0("{",extends("envRefClass"), "}") 291 exclude <- grep("Objects from the Class", sections) 292 if(nmeths < 1) 293 exclude <- c(exclude, grep("Methods", sections)) 294 else 295 .meths.head <- "\\section{Class-Based Methods}{" 296 if(nslots < 2) # just the data slot, usually 297 exclude <- c(exclude, grep("Slots", sections)) 298 Rdtxt <- Rdtxt[-exclude] 299 extdsthead <- "section{Extends}" # has to be there 300 extds <- Rdtxt[[extdsthead]] 301 drop <- rep(FALSE, length(extds)) 302 for(class in envRefX) #drop the envRefClass & its superclasses 303 drop <- drop | grepl(class, extds, fixed = TRUE) 304 extds <- extds[!drop] 305 extds <- append(extds, "\nAll reference classes extend and inherit methods from \\code{\"\\linkS4class{envRefClass}\"}.\n", length(extds)-1) 306 Rdtxt[[extdsthead]] <- extds 307 fieldClasses <- refClassFields(clDef) 308 nfields <- length(fieldClasses) 309 .fields <- if (nfields > 0) { 310 fieldnames <- names(fieldClasses) 311 .fields.head <- c("\\section{Fields}{", " \\describe{") 312 .fields.body <- paste0(" \\item{\\code{", fieldnames, 313 "}:}", "{Object of class \\code{", 314 fieldClasses, "} ~~ }") 315 .fields.tail <- c(" }","}") 316 c(.fields.head, .fields.body, .fields.tail) 317 } else character() 318 methodDefs <- as.list(clDef@refMethods) 319 nmethods <- length(methodDefs) 320 if(nmethods > 0) { 321 thisClassDefs <- match(vapply(methodDefs, function(x) x@refClassName, ""), clDef@className, 0) > 0 322 otherMethods <- methodDefs[!thisClassDefs] 323 methodDefs <- methodDefs[thisClassDefs] 324 .methods <- 325 c(.meths.head, .refMethodDescription(methodDefs, fieldnames, otherMethods), "}") 326 } 327 else 328 .methods <- character() 329 c(Rdtxt, 330 list("section{Fields}" = .fields, 331 "section{ClassMethods}" = .methods) 332 ) 333} 334 335.refMethodDescription <- function(methodDefs, fieldnames, otherMethods) { 336 methodnames <- names(methodDefs) 337 methodargs <- vapply(methodDefs, function(x) 338 paste0("(", paste(formalArgs(x), collapse=", "), ")"), "") 339 if(length(methodnames) > 0) { 340 .methods.head <- " \\describe{" 341 .methods.body <- 342 paste0(" \\item{\\code{", 343 methodnames, methodargs, 344 "}:}", "{ ~~ }") 345 .methods <- c(.methods.head, .methods.body, " }") 346 } 347 else 348 .methods <- character() 349 methodclasses <- vapply(otherMethods, 350 function(x) if(is(x, "refMethodDef")) x@refClassName else "<unknown>", "") 351 ## don't report the standard methods from envRefClass 352 superclass <- methodclasses != "envRefClass" 353 otherMethods <- otherMethods[superclass] 354 methodclasses <- methodclasses[superclass] 355 if(length(otherMethods)) { 356 methodnames <- names(otherMethods) 357 methodnames <- gsub("[#].*","", methodnames) 358 .methods <- c(.methods, 359 "\nThe following methods are inherited (from the corresponding class):", 360 paste0(methodnames, ' ("', methodclasses, 361 '")', collapse = ", ") 362 ) 363 } 364 .methods 365} 366 367.makeCallString <- function (def, name = substitute(def), args = formalArgs(def)) 368{ 369## 370## need this for experimentation because the function is not exported 371## 372 if (is.character(def)) { 373 if (missing(name)) 374 name <- def 375 def <- getFunction(def) 376 } 377 if (is.function(def)) 378 paste0(name, "(", paste(args, collapse = ", "), ")") 379 else "" 380} 381