[Rd] package.skeleton.S4

[John Chambers]

Christophe,

Thanks for your work; unfortunately,  at the same time you were 
developing your version, the original function was being extended in the 
same direction.

The version of package.skeleton() to be included in the 2.7.0 release of 
R will deal with S4 classes and methods.

When you have a chance, it would be helpful if you would try out this 
version, and let us know whether it deals with your examples.

Version 2.7 of R is currently in alpha testing, meaning that you would 
have to compile R from source, so you might prefer to wait.  See the 
pointer from the main R web page.  The projected release date for 2.7.0 
is April 22.

John

Christophe Genolini wrote:
> 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")
>
> ______________________________________________
> R-devel at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
>
>