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