The R Project SVN R

#  File src/library/methods/R/promptClass.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2014 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

promptClass <-
function (clName, filename = NULL, type = "class",
      keywords = "classes", where = topenv(parent.frame()),
          generatorName = clName)
{
    classInSig <- function(g, where, cl) {
        ## given a generic g, is class cl in one of the method
        ## signatures for the class?
    cl %in% unique(unlist(findMethods(g, where)@signatures))
    }
    genWithClass <- function(cl, where) {
    ## given a class cl
    ## obtain list of all generics with cl in
    ## one of its signatures
    allgen <- getGenerics(where = where)
    ok <- as.logical(unlist(lapply(allgen, classInSig, cl = cl, where = where)))
    allgen[ok]
    }

    sigsList <- function (g, where)
      ## given a generic g, obtain list with one element per signature,
      ## with argument names inserted
    {
        methods <- findMethods(g, where)
    value <- methods@signatures
        args <- methods@arguments
        if(length(value)) {
            ## name the individual signature elements for output
            length(args) <- length(value[[1]]) # all sigs are same length
            value <- lapply(value, function(x){names(x) <- args; x})
        }
        value
    }
    slotClassWithSource <- function(clname) {
    clDef <- getClassDef(clname)
    extds <- names(clDef@contains)
    allslots <- getSlots(clDef) ## establishes all slots, in the right order
    for(j in rev(seq_along(extds))) {
        i <- extds[[j]]
        slotsi <- getSlots(getClass(i))
        if(length(slotsi))
        allslots[names(slotsi)] <- paste0("\"", as.character(slotsi),
                          "\", from class \"", i, "\"")
    }
    slotsi <- getSlots(clDef)
    if(length(slotsi))
        allslots[names(slotsi)] <- paste0("\"", as.character(slotsi),"\"")
    allslots
    }
    cleanPrompt <- function(object, name) {
        ## get the prompt() result and clean out the junk
        ## lines that prompt() creates
        value <- utils::prompt(object, name = name, filename = NA)
        for(i in seq_along(value)) {
            item <- value[[i]]
            bad <- grepl("^ *%", item)
            if(any(bad))
                value[[i]] <- item[!bad]
        }
        value
    }
    pastePar <- function(x) {
        xn <- names(x)
    x <- as.character(x)
    xn <- if(length(xn) == length(x)) paste(xn, "= ") else ""
    paste0("(", paste0(xn, "\"", x, "\"", collapse = ", "), ")")
    }
    escape <- function(txt) gsub("%", "\\%", txt, fixed=TRUE)

    if(is.null(filename))
    filename <- paste0(utils:::topicName(type, clName), ".Rd")
    if(!missing(where) && !is.na(match(clName, getClasses(where))))
        whereClass <- where
    else {
        whereClass <- utils::find(classMetaName(clName))
        if(length(whereClass) == 0L)
            stop(gettextf("no definition of class %s found",
                          dQuote(clName)), domain = NA)
        else if(length(whereClass) > 1L) {
            if(identical(where, topenv(parent.frame()))) {
                whereClass <- whereClass[[1L]]
                warning(gettextf("multiple definitions of %s found; using the one on %s",
                                 dQuote(clName), whereClass), domain = NA)
            }
            else {
                if(exists(classMetaName(clName), where, inherits = FALSE))
                    whereClass <- where
                else
                    stop(sprintf(ngettext(length(whereClass),
                                          "no definition of class %s in the specified position, %s, definition on : %s",
                                          "no definition of class %s in the specified position, %s, definitions on : %s"),
                                 dQuote(clName), where,
                                 paste(whereClass, collapse = ", ")),
                         domain = NA)
            }
        }
    }
    fullName <- utils:::topicName("class", clName)
    clDef <- getClass(clName, where = whereClass)
    .name <- paste0("\\name{", fullName, "}")
    .type <- paste0("\\docType{", type, "}")
    .alias <- paste0("\\alias{", fullName, "}")
    .title <- sprintf("\\title{Class \\code{\"%s\"}}", clName)
    .desc <- paste0("\\description{",
                    "\n%%  ~~ A concise (1-5 lines) description of what the class is. ~~",
                    "\n}")
    slotclasses <- getSlots(clDef)
    slotnames <- names(slotclasses)
    slotclasses <- as.character(slotclasses)
    nslots <- length(slotclasses)
    clNameQ <- paste0('"', clName, '"')
    .usage <- "\\section{Objects from the Class}"
    virtualClass <- isVirtualClass(clName)
    if(virtualClass) {
    .usage <- paste0(.usage, "{A virtual Class: No objects may be created from it.}")
        generator <- NULL # regardless of what exists
    }
    else {
        if(exists(generatorName, where, inherits = FALSE))
            generator <- get(generatorName, where, inherits = FALSE)
        else
            generator <- NULL
        if(is(generator, "classGeneratorFunction")) {
            promptGenerator <- cleanPrompt(generator, generatorName)
            callString <- .makeCallString(generator, generatorName)
            .alias <- c(.alias, promptGenerator$aliases)
            ## the rest of the promptGenerator will be added later
        }
        else {
            initMethod <- unRematchDefinition(selectMethod("initialize", clName))
            argNames <- formalArgs(initMethod)
            ## but for new() the first argument is the class name
            argNames[[1L]] <- clNameQ
            callString <- .makeCallString(initMethod, "new", argNames)
        }
    .usage <-
            c(paste0(.usage,"{"),
              paste0("Objects can be created by calls of the form \\code{",
                     callString,
                     "}."),
              "%%  ~~ describe objects here ~~ ",
              "}")
    }
    .slots <- if (nslots > 0) {
    slotclasses <- slotClassWithSource(clName)
    slotnames <- names(slotclasses)
    .slots.head <- c("\\section{Slots}{", "  \\describe{")
    .slots.body <-  paste0("    \\item{\\code{", slotnames,
                               "}:}", "{Object of class \\code{",
                               slotclasses, "} ~~ }")
    .slots.tail <- c("  }","}")
    c(.slots.head,  .slots.body,    .slots.tail)
    } else character()
    .extends <- clDef@contains
## FIXME: the superclass slots should be marked as such
##       and left *optional* to be documented
    if(length(.extends)) {
    .extends <- showExtends(.extends, printTo = FALSE)
    .extends <-
        c("\\section{Extends}{",
          paste0("Class \\code{\"\\linkS4class{",
            .extends$what,
            "}\"}, ",
            ## Add Rd markup to 'by class "CLASS"' results
            gsub("^(by class) (\".*\")$", "\\1 \\\\code{\\2}",
             .extends$how),
            "."),
          "}")
    }
    else
    .extends <- character()
    nmeths <- length(methnms <- genWithClass(clName, where = whereClass))
    .meths.head <- "\\section{Methods}{"
    .methAliases <- ""
    if (nmeths > 0) {
    .meths.body <- "  \\describe{"
    for (i in 1L:nmeths) {
        .sig <- sigsList(methnms[i], where = whereClass)
        for (j in seq_along(.sig)) {
        if (!all(is.na(match(.sig[[j]],clName)))) {
            methn.i <- escape(methnms[i])
            .meths.body <-
            c(.meths.body,
              paste0("    \\item{",
                 methn.i, "}{\\code{signature",
                 pastePar(.sig[[j]]), "}: ... }"))

            cur <- paste(.sig[[j]], collapse = ",")
            .methAliases <- paste0(.methAliases, "\\alias{",
                       methn.i, ",", cur, "-method}\n")
        }
        }
    }
    .meths.body <- c(.meths.body, "  }")
    }
    else {
    .meths.head <- "\\section{Methods}{"
    .meths.body <- paste("No methods defined with class", clNameQ,
                             "in the signature.")
    }
    .meths.tail <- "}"
    .keywords <- paste0("\\keyword{", keywords, "}")

    Rdtxt <-
    list(name = .name,
         type = .type,
         aliases = .alias,
         methAliases = .methAliases,
         title = .title,
         description = .desc,
         "section{Objects from the Class}" = .usage,
         "section{Slots}" = .slots,
         "section{Extends}" = .extends,
         "section{Methods}" =
         c(.meths.head, .meths.body, .meths.tail),
         references = paste("\\references{\n%%  ~~put references to the",
         "literature/web site here~~\n}"),
         author = "\\author{\n%%  ~~who you are~~\n}",
         note =
         c("\\note{\n%%  ~~further notes~~\n}",
           "",
           paste("%% ~Make other sections like Warning with",
             "\\section{Warning }{....} ~"),
           ""),
         seealso =
         c("\\seealso{",
           paste("%%  ~~objects to See Also as",
             "\\code{\\link{~~fun~~}}, ~~~"),
           paste("%%  ~~or \\code{\\linkS4class{CLASSNAME}}",
             "for links to other classes ~~~"),
           "}"),
         examples = c("\\examples{",
         paste0("showClass(", clNameQ, ")"),
         "}"),
         keywords = .keywords)

    if(is(clDef, "refClassRepresentation"))
        Rdtxt <- refClassPrompt(clDef, Rdtxt, nmeths, nslots, .meths.head)
    else if(is(generator, "classGeneratorFunction")) {
        ## add in the actual usage, arguments sections, mostly to make
        ## CMD check happy
        what <-  c("usage", "arguments")
        Rdtxt[what] <- promptGenerator[what]
    }

    if(is.na(filename)) return(Rdtxt)

    cat(unlist(Rdtxt), file = filename, sep = "\n")
    .message("A shell of class documentation has been written",
             .fileDesc(filename), ".\n")
    invisible(filename)
}

## used in promptClass() above and in promptMethods() :
.fileDesc <- function(file) {
    if(is.character(file)) {
    if(nzchar(file))
        paste(" to the file", sQuote(file))
    else
        " to the standard output connection"
    }
    else if(inherits(file, "connection"))
    paste(" to the connection",
              sQuote(summary(file)$description))
    else "" # what, indeed?
}

refClassPrompt <- function(clDef, Rdtxt, nmeths, nslots, .meths.head) {
    ## exclude some sections that are usually irrelevant
    sections <- names(Rdtxt)
    envRefX <- paste0("{",extends("envRefClass"), "}")
    exclude <- grep("Objects from the Class", sections)
    if(nmeths < 1)
        exclude <- c(exclude, grep("Methods", sections))
    else
        .meths.head <- "\\section{Class-Based Methods}{"
    if(nslots < 2) # just the data slot, usually
        exclude <- c(exclude, grep("Slots", sections))
    Rdtxt <- Rdtxt[-exclude]
    extdsthead <- "section{Extends}" # has to be there
    extds <- Rdtxt[[extdsthead]]
    drop <- rep(FALSE, length(extds))
    for(class in envRefX) #drop the envRefClass & its superclasses
        drop <- drop | grepl(class, extds, fixed = TRUE)
    extds <- extds[!drop]
    extds <- append(extds, "\nAll reference classes extend and inherit methods from \\code{\"\\linkS4class{envRefClass}\"}.\n", length(extds)-1)
    Rdtxt[[extdsthead]] <- extds
    fieldClasses <- refClassFields(clDef)
    nfields <- length(fieldClasses)
    .fields <- if (nfields > 0) {
    fieldnames <- names(fieldClasses)
    .fields.head <- c("\\section{Fields}{", "  \\describe{")
    .fields.body <- paste0("    \\item{\\code{", fieldnames,
                               "}:}", "{Object of class \\code{",
                               fieldClasses, "} ~~ }")
    .fields.tail <- c("  }","}")
    c(.fields.head,  .fields.body,  .fields.tail)
    } else character()
    methodDefs <- as.list(clDef@refMethods)
    nmethods <- length(methodDefs)
    if(nmethods > 0) {
        thisClassDefs <- vapply(methodDefs, function(x) x@refClassName, "") %in% clDef@className
        otherMethods <- methodDefs[!thisClassDefs]
        methodDefs   <- methodDefs[ thisClassDefs]
        .methods <-
            c(.meths.head, .refMethodDescription(methodDefs, fieldnames, otherMethods), "}")
    }
    else
        .methods <- character()
    c(Rdtxt,
      list("section{Fields}" = .fields,
           "section{ClassMethods}" = .methods)
      )
}

.refMethodDescription <- function(methodDefs, fieldnames, otherMethods) {
    methodnames <- names(methodDefs)
    methodargs <- vapply(methodDefs, function(x)
             paste0("(", paste(formalArgs(x), collapse=", "), ")"), "")
    if(length(methodnames) > 0) {
        .methods.head <- "  \\describe{"
        .methods.body <-
            paste0("    \\item{\\code{",
                   methodnames, methodargs,
                   "}:}", "{ ~~ }")
        .methods <- c(.methods.head,  .methods.body, "  }")
    }
    else
        .methods <- character()
    methodclasses <- vapply(otherMethods,
          function(x) if(is(x, "refMethodDef")) x@refClassName else "<unknown>", "")
    ## don't report the standard methods from envRefClass
    superclass <- methodclasses != "envRefClass"
    otherMethods <- otherMethods[superclass]
    methodclasses <- methodclasses[superclass]
    if(length(otherMethods)) {
        methodnames <- names(otherMethods)
        methodnames <- gsub("[#].*","", methodnames)
        .methods <- c(.methods,
                      "\nThe following methods are inherited (from the corresponding class):",
                      paste0(methodnames, ' ("', methodclasses,
                             '")', collapse = ", ")
                      )
    }
    .methods
}

.makeCallString <- function (def, name = substitute(def), args = formalArgs(def))
{
##
## need this for experimentation because the function is not exported
##
    if (is.character(def)) {
    if (missing(name))
        name <- def
    def <- getFunction(def)
    }
    if (is.function(def))
    paste0(name, "(", paste(args, collapse = ", "), ")")
    else ""
}