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)[EMAIL
> PROTECTED]>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@r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
>
>
______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
