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
