[Rd] package.skeleton.S4

[Christophe Genolini]

Hi the devel list.

I am adapting the package.skeleton to S4 classes and methods
I would have been very proud to post a new working function on this list.
Unfortunately, I do not manage to solve all the problems. Mainly

 - sys.source does not compile a file with setClass
 - dumpMethod does not exists yet

In the following code, thise two problems are notified by a line 
#################

Still with this two issues, it is possible to use package.skeleton.S4 in 
the following way:
 - first run package.skeleton (in the classical way, on a file or in the 
console).
    This creates the directories and the files
 - then run package.skeleton.S4.
     It has to be done
      * using the code_files option (since dumpMethod does not exists)
      * providing the list of the class (since sys.source does not 
compile setClass)
      * using the same path than package.skeleton

At this three conditions, package.skeleton.S4 will :
 - modify the DESCRIPTION package,
 - run promptClass on the classes gived in the list,
 - run promptMethod on all the methods related to the classes gives in 
the list.

I tryed to solve the sys.source problem, but I am not good enough in R 
to do it myself.
I do not even know if it is something hard to do or very easy. So I post 
this uncompleted function...
If someone is interested in fixing it and then adding it somewhere,
I then will write the package.skeleton.S4.Rd

sincerly

Christophe


--- 8< ----------------- package.skeleton.S4 ---------------------------

package.skeleton.S4 <- function(name = "anRpackage", list, environment = 
.GlobalEnv,
    path = ".", force = FALSE, namespace = FALSE, code_files = 
character(),S4=FALSE)
{
    cat(missing(list)," EEE\n")
    ### If pakage.skeleton has not been run, run it on false data
    dir <- file.path(path, name)
    code_dir <- file.path(dir, "R")
    docs_dir <- file.path(dir, "man")
    data_dir <- file.path(dir, "data")
    if (!file.exists(dir)){
        environment <- new.env()
        assign("falseData-ToErase",NULL,environment)
        
package.skeleton(name=name,environment=environment,path=path,namespace=namespace)
    }else{}

    ### Build up the list_S4
    ###   If list_S4 is empty :
    ###      If code_files_S4 is not empty, the file in code_file_S4 are 
source.
    ###      then list receive ls() after removing ".__C__" (either if 
code_files is empty or not)
    if (!is.character(code_files)){stop("'code_files S4' should be a 
character vector")}else{}
    use_code_files <- length(code_files) > 0

    if (missing(list)){
################################################################################
# Has to be false
# since sys.source does not work :-(
        if (use_code_files){
            environment <- new.env()
            for (cf in code_files){sys.source(cf, envir = environment)}
        }else{}
        list <- ls(pattern=".__C__",all.names=TRUE)
        list <- substr(list,7,nchar(list))
    }else{}

    ### Check that the parameters are of correct type
    if (!is.character(list)){stop("'list' should be a character vector 
naming R objects")}else{}
    if (!is.logical(namespace) || (length(namespace) != 
1)){stop("'namespace' should be a single logical")}else{}
    curLocale <- Sys.getlocale("LC_CTYPE")
    on.exit(Sys.setlocale("LC_CTYPE", curLocale), add = TRUE)
    if (Sys.setlocale("LC_CTYPE", "C") != "C"){warning("cannot turn off 
locale-specific chars via LC_CTYPE")}else{}

    ### Remove non existing object from the list
    have <- sapply(list, isClass, where = environment)
    if (any(!have))
        warning(sprintf(ngettext(sum(!have), "class '%s' not found",
            "class '%s' not found"), paste(sQuote(list[!have]),
            collapse = ", ")), domain = NA)
    list <- list[have]
    if (!length(list))
        stop("no R classes specified or available")
    
    ### Addition to DESCRIPTION
    message("Adding to DESCRIPTION ...")
    description <- file(file.path(dir, "DESCRIPTION"), "a+b")
    cat("\nDepends: methods\nLazyLoad: yes\nCollate: gives the order in 
which file shall be sourced\n",append=TRUE,file = description,sep = "")
    close(description)

    ### Remove elements starting with "." from the list
    internalObjInds <- grep("^\\.", list)
    internalObjs <- list[internalObjInds]
    if (any(internalObjInds)){list <- list[-internalObjInds]}else{}

    ### Remplace strange char by "_" and check the name validity (but 
only if code_file is user define)
    if (!use_code_files){
        list0 <- gsub("[[:cntrl:]\"*/:<>?\\|]", "_", list)
        wrong <- 
grep("^(con|prn|aux|clock\\$|nul|lpt[1-3]|com[1-4])(\\..*|)$",list0)
        if (length(wrong)){list0[wrong] <- paste("zz", list0[wrong], sep 
= "")}else{}
        ok <- grep("^[[:alnum:]]", list0)
        if (length(ok) < length(list0)){list0[-ok] <- paste("z", 
list0[-ok], sep = "")}else{}
        list1 <- tolower(list0)
        list2 <- make.unique(list1, sep = "_")
        changed <- (list2 != list1)
        list0[changed] <- list2[changed]
    }else{
        list0 <- list
    }
    names(list0) <- list

    ### If code_file is empty, it save all invisible in pack-internal.R 
and all the function one by one in its file
    ### If code_file is not empty, is save the code_file
    if (!use_code_files){
        message("Saving functions and data ...")
        warning("*** Does not work: dumpClass and dumpMethod are not 
implemented yet ***")
        warning("*** Use code_file instead ***")
###########################################################################
#        if (any(internalObjInds)){dump(internalObjs, file = 
file.path(code_dir, sprintf("%s-internal.R",name)))}else{}
#        for (item in list) {
#        if (is.function(get(item, envir = environment))){
#            dump(item, file = file.path(code_dir, 
sprintf("%s.R",list0[item])))
#        }else{
#            try(save(list = item, file = 
file.path(data_dir,sprintf("%s.rda", item))))
#        }
    }else{
        message("Copying code files ...")
        file.copy(code_files, code_dir)
    }

    ### Help file
    ### For all the internal, a single help file saying "not for user"
    message("Making help files ...")
    if (any(internalObjInds)) {
        Rdfile <- file(file.path(docs_dir, 
sprintf("%s-internal-S4.Rd",name)), "wt")
        cat("\\name{", name, "-internal}\n", "\\title{Internal ",name, " 
objects}\n", file = Rdfile, sep = "")
        for (item in internalObjs) {cat("\\alias{", item, "}\n", file = 
Rdfile, sep = "")}

        cat("\\description{Internal ", name, " classes.}\n",
            "\\details{These are not to be called by the user.}\n",
            "\\keyword{internal}", file = Rdfile, sep = "")
        close(Rdfile)
    }
    yy <- try(suppressMessages({
        sapply(list,function(item){
            promptClass(item,filename = file.path(docs_dir, 
sprintf("%s.Rd",list0[item])))
        })
        
        listMethod <- unclass(getGenerics())
        sapply(listMethod,function(metho){
            if(any(sapply(list,function(lis){existsMethod(metho,lis)}))){
                promptMethods(metho,filename = file.path(docs_dir, 
sprintf("%s.Rd",metho)))
            }else{}
            return(invisible())
        })
        
        
    }))
    
    if (inherits(yy, "try-error")){stop(yy)}else{}
    if (length(list.files(code_dir)) == 0){unlink(code_dir, recursive = 
TRUE)}else{}
    if (length(list.files(data_dir)) == 0){unlink(data_dir, recursive = 
TRUE)}else{}
    message("Done.")
    message(gettextf("Further steps are described in 
'%s'.",file.path(dir, "Read-and-delete-me")), domain = NA)
}

    
# Example
# Save in myPack.r    
---- 8< ---------------File myPack.r -----------------
    
`f1` <- function(x){cat("\nXXX F1 = ",x,"XXX\n")}
`.f2` <- function(x){cat("\nXXX F2 = ",f1(x^2),"XXX\n")}


# Save in myPackS4.r    
---- 8< ---------------File myPackS4.r ---------------

setClass("AA",representation(a="numeric"))
setGeneric("aze",function(z){standardGeneric("aze")})
setMethod("print","AA",function(x){cat("C'est cool")})
setMethod("aze","AA",function(z){cat("C'est hyper cool")})



setClass("BB",representation(b="numeric"),validity=function(object){object at b>0})
setMethod("plot","BB",function(x,y){cat("CCC'est cool")})
setMethod("aze","BB",function(z){cat("CCC'est hyper cool")})

---- 8< -----------------------------------------------


# Example of use :

package.skeleton("pack",code_files="pack.r")
package.skeleton.S4("pack",list=c("AA","BB"),code_files="packS4.r")