Nothing
inst/original/rbsb2.code.r
In rbsb: set of ancillary functions
###########################################
###########################################
########
#((((((( NEW S4 CLASS des
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8des <- function(object)
#TITLE checks a /des/
#DESCRIPTION
# This function checks a /des/ objects
#DETAILS
# It is the validity method for /des/ objects.
#KEYWORDS classes
#INPUTS
#{object} <<The des object to be validated.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_08_31
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="des") {
erreur(NULL,paste("This object is not of class 'des' but '",class(object),"'",sep=""));
}
res <- character(0);
if(length(object@name)!=1) {res <- c(res,"des@name must be a character of length one");}
if(length(object@orig)>=2) {res <- c(res,"des@orig must not be a vector");}
if(length(object@time)>=2) {res <- c(res,"des@time must not be a vector");}
if(length(object@defi)>=2) {res <- c(res,"des@defi must not be a vector");}
if(length(object@role)>=2) {res <- c(res,"des@role must not be a vector");}
if (length(res)== 0) { res <- TRUE;
} else { erreur(res,w=rbsb.mwa);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
# description
setClass("des", representation(
name="character", # name of the object being described
orig="character", # scalar giving the origin
time="character", # scalar giving the time of creation/modification
defi="character", # scalar giving the definition
role="character", # scalar giving the role of the structure
comm="character" # free vector, a component = a paragraph
),
prototype=list(
name="rbsb",
orig=paste("Created by rbsb"),
time="unknown",
defi="undefined",
role=character(0),
comm=character(0)),
validity=valid8des
);
#
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8des <- function(x,...,what="ndr",empha=1)
#TITLE prints a des object
#DESCRIPTION
# This function prints in a /des/ object.
#DETAILS
# Global constant \code{rbsb.mwi} is used to justify the paragraphes.
# It is the specific print for /des/ objects.
#KEYWORDS classes
#INPUTS
#{x} <<The \code{des} object to print.>>
#[INPUTS]
#{\dots} <<Further arguments to be passed to the print function.>>
#{what} <<the fields to print:
# \code{a}=all fields,
# \code{n}=name,
# \code{d}=definition,
# \code{o}=origin,
# \code{t}=time,
# \code{r}=role,
# \code{c}=comments.>>
#{empha} <<Emphasize level of printing;
# between 0 and 10>>
#VALUE
# nothing but a print is performed
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
# Add a beginnnig way (giving only the first characters of
# each slot for not too large reports.
#AUTHOR J.-B. Denis
#CREATED 08_08_21
#REVISED 10_09_15
#--------------------------------------------
{
# some checking
che <- valid8des(x);
if (!identical(che,TRUE)) {
erreur(che,"/des/ is not valid");
}
empha <- round(max(0,min(10,empha)));
nemph <- empha -2;
what <- tolower(what);
if (expr3present("a",what)) { what <- "ndortc";}
# preparing the titles
tt <- c("Name","Definition","Origin","Time","Role","Comment(s)");
# preparing the constant according to the emphasis
if (empha == 0) {
sep=0; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- " ";
}
if (empha == 1) {
sep=0; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- " ";
}
if (empha == 2) {
sep=0; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- " ";
}
if (empha == 3) {
sep=0; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- "-";
}
if (empha == 4) {
sep=1; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- "==";
}
if (empha == 5) {
sep=1; ed <- form3repeat(" ",2*nemph);
nbs <- 20; sou <- "==";
}
if (empha == 6) {
sep=2; ed <- form3repeat(" ",2*nemph);
nbs <- 2; sou <- form3repeat(" ",50,FALSE,TRUE);
}
if (empha >= 7) {
sep=2; ed <- form3repeat(" ",2*nemph);
nbs <- 3; sou <- form3repeat("=",50,FALSE,TRUE);
}
#
# printing
if (expr3present("n",what)) {
if (!isempty(x@name)) {
if (x@name != "") {
form3titre(c(tt[1],x@name),nemph);
}}}
if (expr3present("d",what)) {
if (!isempty(x@defi)) {
if (x@defi != "") {
if (!isempty(x@name)) {
tt[2] <- paste("<",tt[2]," of '",x@name,"':>",sep="");
}
form3paragraphe(c(tt[2],x@defi),nemph,
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
if (expr3present("o",what)) {
if (!isempty(x@orig)) {
if (x@orig != "") {
form3paragraphe(c(tt[3],x@orig),nemph,
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
if (expr3present("t",what)) {
if (!isempty(x@time)) {
if (x@time != "") {
form3paragraphe(c(tt[4],x@time),nemph,
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
if (expr3present("r",what)) {
if (!isempty(x@role)) {
if (x@role != "") {
form3paragraphe(c(tt[5],x@role),nemph,
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
if (expr3present("c",what)) {
if (!isempty(x@comm)) {
if ((x@comm[1] != "")|(length(x@comm)>1)) {
form3paragraphe(c(tt[6],x@comm),max(0,nemph),
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
form3repeat(sou,nbs,TRUE);
# returning
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#
#
setMethod("print",signature(x = "des"), print8des);
###########################################
###########################################
########
#((((((( NEW S4 CLASS faux
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8faux <- function(object)
#TITLE checks a /faux/
#DESCRIPTION
# This function checks a /faux/ objects
#DETAILS
# It is the validity method for /faux/ objects.
#KEYWORDS error
#INPUTS
#{object} <<The faux object to validate.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_08_31
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="faux") {
erreur(NULL,paste("This object is not of class 'faux' but '",class(object),"'",sep=""));
}
if ((object@level != 0) & (object@level != 1) & (object@level != 2)) {
re1 <- "faux@level must be 0, 1 or 2";
} else { re1 <- TRUE;}
re2 <- valid8des(as(object,"des"));
#
res <- character(0);
if (!identical(re1,TRUE)) { res <- c(res,re1);}
if (!identical(re2,TRUE)) { res <- c(res,re2);}
if (identical(res,character(0))) { res <- TRUE;}
#
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
################################################################################
setClass("faux",
representation(level="numeric"), # level of the error
prototype(level=0),
contains="des", # extension of a description
validity=valid8faux
);
################################################################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8faux <- function(x,...,what=2)
#TITLE prints a faux object
#DESCRIPTION
# This function prints in a interpreted way a /faux/ object.
#DETAILS
# Global constant \code{rbsb.mwi} is used to justify the paragraphes.
# It is the specific print for /faux/ objects.
#KEYWORDS error
#INPUTS
#{x} <<The faux object to be printed.>>
#[INPUTS]
#{\dots} <<Further arguments to be passed to the print function.>>
#{what} <<the level of printing
# 0= only the definition,
# 1= the origin and the definition
# 2= everything.
#VALUE
# nothing but a print is performed
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.fau1,what=2);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_01_21
#REVISED 09_09_29
#--------------------------------------------
{
#
# printing
#
what <- "ndo";
if (what==0) { what <- "d";}
if (what==2) { what <- "a";}
#
form3titre(paste("/faux/ with a level of",x@level));
print(as(x,"des"),what=what);
# returning
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
setMethod("print",signature(x = "faux"),print8faux);
###########################################
###########################################
########
#((((((( NEW S4 CLASS daf
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8daf <- function(object)
#TITLE checks a /daf/
#DESCRIPTION
# This function checks /daf/ objects
#DETAILS
# It is the validity method for /daf/ objects.
#KEYWORDS classes
#INPUTS
#{object} <<The daf object to be validated.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_01
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="daf") {
erreur(NULL,paste("This object is not of class 'daf' but '",class(object),"'",sep=""));
}
res <- character(0);
# checking the 'what' parameter
if (!(object@what %in% c("t","d","f","c","c2"))) {
res <- c(res,paste(object@what,"'what' must be 't', 'd' or 'f'"));
}
# checking the other fields
# to avoid error whe R is checking the package
if (!is.null(rbsb.snp)) { # to prevent R checking harassment
rres <- NULL; # to prevent R checking harassment
if ((object@what=="t") |
(object@what=="c") |
(object@what=="c2")) {
if (file.access(object@valu)<0) {
res <- c(res,paste(object@valu,"No file of this name seems accessible."));
}
}
if (object@what=="d") {
if(!exists(object@valu)) {
res <- c(res,paste(object@valu,"No data.frame under this name: should be a data.frame"));
}
coda <- paste("rres <- class(",object@valu,")");
eval(parse(text=coda));
if (rres!="data.frame") {
res <- c(res,paste(list(object@valu,res),"A data.frame was expected under this variable"));
}
}
if (object@what=="f") {
if(!exists(object@valu)) {
res <- c(res,paste(object@valu,"No object under this name: should be a function"));
}
coda <- paste("rres <- class(",object@valu,")");
eval(parse(text=coda));
if (rres!="function") {
res <- c(res,paste(list(object@valu,res),"A function was expected under this variable"));
}
}
} # to prevent R checking harassment
#
if (length(res)== 0) { res <- TRUE;
} else { erreur(res,w=rbsb.mwa);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
setClass("daf", representation(
des="des", # description of the data frame
what="character", # indication about the way the data.frame is
# available. 3 currently ways:
# 't' through a text file to be read
# 'd' through a data.frame itself
# 'f' through a function to be called without argument
valu="character" # the complete path of the text file when what=='t'
# the data.frame name when what=='d'
# the function name when what=='f'
),
prototype(des=new("des",name="rbsb",
orig=paste("Created by rebastaba"),
time=date(),
defi="prototype",
role=character(0),
comm=character(0)),
what="d",
valu="rbsb.dfr0"),
validity=valid8daf
);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8daf <- function(x,what="nr",whi=1:10)
#TITLE prints a daf object
#DESCRIPTION
# This function prints a /daf/ object.
#DETAILS
# It is the specific print function for /daf/ objects.
#KEYWORDS print
#PKEYWORDS daf
#INPUTS
#{x} <<The daf object.>>
#[INPUTS]
#{what} << which part of the description to print
# (see \code{print8des}).>>
#{whi} << which rows to print?\cr
# when -1: none is printed,\cr
# when 0: all are printed,\cr
# when a vector: indicates the numbers of rows to print
# (default = the first ten),\cr
# when a value: the percentage to be printed
# (50 = half of the rows)
# >>
#VALUE
# returns nothing but a printing is performed
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.daf2);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_23
#REVISED 10_02_11
#--------------------------------------------
{
# some checks
if (rbsb.mck) {
che <- valid8daf(x);
if (!identical(che,TRUE)) {
erreur(che,"/daf/ is not valid");
}
check4tyle(what,rbsb.chara,1,message="'what' must be character(1)");
}
#
nsou <- 39;
# dealing with the daf.null case
if (identical(x,rbsb.daf0)) {
form3repeat("-",nsou,TRUE);
cat("<<< daf.null >>>\n");
form3repeat("-",nsou,TRUE);
return(invisible());
}
# loading the data.frame
values <- get8daf(x);
# looking for the rows to print
if (min(whi) < 0) {
quelles <- numeric(0);
} else {
nlig <- nrow(values);
if ((identical(whi,0))|(nlig==0)) {
quelles <- bc(nlig);
} else {
if (length(whi) == 1) {
nli <- min(100,whi);
quelles <- seq(1,nlig,length=max(1,round(nlig*nli/100)));
quelles <- round(quelles);
} else {
quelles <- intersect(whi,bc(nlig));
if (length(quelles) <= 0) { quelles <- 1:min(10,nlig);}
}
}
}
# printing the description
form3repeat("-",nsou,TRUE);
print(x@des,what);
#printing the values
form3repeat("-",nsou,TRUE);
if (length(quelles)>0) {
print(values[quelles,]);
}
# returning
form3repeat("-",nsou,TRUE);
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
setMethod("print",signature(x = "daf"), print8daf);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
daf2list <- function(daf,simple=TRUE)
#TITLE transforms a /daf/ into a list
#DESCRIPTION
# This function transforms a /daf/ object
# into a standard list. The shortened way is used
# when \code{simple}.
#DETAILS
# By simple or shortened, it is meant that the list
# is given with a simple level of a \code{character(3)}
# (most frequent use).
#KEYWORDS misc
#PKEYWORDS daf
#INPUTS
#{daf} <<The daf object to be transformed.>>
#[INPUTS]
#{simple} <<indicates the way the list must be created.>>
#VALUE
# the resulting list
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# daf2list(rbsb.daf1);
# daf2list(NULL);
# daf2list(rbsb.daf1,FALSE);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_06_21
#REVISED 10_06_28
#--------------------------------------------
{
# degenerate case
if (isempty(daf)) { return(rbsb.lis0);}
# some checks
if (rbsb.mck) {
che <- valid8daf(daf);
if (!identical(che,TRUE)) {
erreur(che,"/daf/ is not valid");
}
}
#
if (simple) {
res <- list(daf=c(daf@des@name,daf@what,daf@valu));
} else {
res <- des2list(daf@des);
res$what <- daf@what;
res$valu <- daf@valu;
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
list2daf <- function(li)
#TITLE transforms a list into a /daf/
#DESCRIPTION
# This function transforms a list comprising
# the necessary components into a /daf/ object.
# The components of the list must be either the
# direct transcription of the slot hierarchy of /daf/
# or (shortened way) a component named \code{daf} comprising a
# \code{character(3)} with \code{des@name}, \code{what} and \code{valu} slots.
#DETAILS
# The list \code{li} can comprise more components
# which are ignored. If \code{li$daf} exists, it will
# have priority over the possible slot components.
#KEYWORDS misc
#PKEYWORDS daf
#INPUTS
#{li} <<The list to be transformed into a /daf/.>>
#[INPUTS]
#VALUE
# returns the resulting /daf/ object.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# lu <- daf2list(new("daf",des=new("des",name="rbsb",
# orig=paste("Created by rebastaba"),
# time=date(),
# defi="prototype",
# role=character(0),
# comm=character(0)),
# what="d",
# valu="rbsb.dfr0"));
# list2daf(lu);
# list2daf(list(daf=c("simple","d","rbsb.dfr0")));
# list2daf(rbsb.lis0);
#REFERENCE
#SEE ALSO daf2list
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_06_22
#REVISED 10_06_28
#--------------------------------------------
{
# degenerate case
if (isempty(li)) { return(rbsb.daf0);}
if (isempty(li$daf)) {
# slot case
if (rbsb.mck) {
didi <- setdiff(slotNames("daf"),names(li));
if (length(didi) > 1) {
erreur(names(li),"The components of this list does not allow to create a /daf/ through the slot case");
}
}
#
res <- new("daf",des=list2des(li$des),
what=li$what,
valu=li$valu);
} else {
# simple case
if (rbsb.mck) {
check4tyle(li$daf,rbsb.chara,3,message="A character(3) was expected: name, what, valu");
}
res <- new("daf",des=char2des(li$daf[1]),
what=li$daf[2],
valu=li$daf[3]);
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
list2des <- function(li)
#TITLE transforms a consistent list into a /des/ object
#DESCRIPTION
# Just analyzing the components of the list
# (consistent names have to be used) which are supposed
# to be character and tackle them to produce consistent
# slots of a /des/ object.
# The components of the list must be either the
# direct transcription of the slots of /des/
# or a component named \code{des} comprising a
# \code{character(1:Inf)} with des@name, des@orig, des@time,
# des@defi,des@role,des@comm in this order.
#DETAILS
#PKEYWORDS des
#KEYWORDS classes
#INPUTS
#{li} <<The list to be transformed into a des object.>>
#[INPUTS]
#VALUE
# The generated 'des' object
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(list2des(list(name="A",role="Just to see",comm="Not very interesting")));
# print(list2des(list(des=c("A","","","","Just to see","Not very interesting"))));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_01_06
#REVISED 10_06_28
#--------------------------------------------
{
if (isempty(li)) { return(rbsb.des0);}
#
if (isempty(li$des)) {
# slot case
if (rbsb.mck) {
if (isempty(li$name)) {
erreur(names(li),"The components of this list does not allow to create a /des/ through the slot case: at least $name is compulsory");
}
}
#
if (is.null(li$orig)) { li$orig <- rbsb.cha0;}
if (is.null(li$time)) { li$time <- rbsb.cha0;}
if (is.null(li$defi)) { li$defi <- rbsb.cha0;}
if (is.null(li$role)) { li$role <- rbsb.cha0;}
if (is.null(li$comm)) { li$comm <- rbsb.cha0;}
if (is.null(li$name)) {
erreur(li,"the component 'name' is compulsory");
}
#
res <- new("des",name=li$name,orig=li$orig,time=li$time,
defi=li$defi,role=li$role,comm=li$comm);
} else {
# simple case
if (rbsb.mck) {
check4tyle(li$des,rbsb.chara,c(1,Inf),message="A character(1:Inf) was expected: name,... orig, time, defi, role, comm.");
}
name <- li$des[1];
nbl <- length(li$des);
if (nbl > 1) { orig <- li$des[2];} else { orig <- rbsb.cha0;}
if (nbl > 2) { time <- li$des[3];} else { time <- rbsb.cha0;}
if (nbl > 3) { defi <- li$des[4];} else { defi <- rbsb.cha0;}
if (nbl > 4) { role <- li$des[5];} else { role <- rbsb.cha0;}
if (nbl > 5) { comm <- li$des[-(1:5)];} else { comm <- rbsb.cha0;}
res <- new("des",name=name,time=time,defi=defi,
role=role,comm=comm);
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
des2list <- function(des,simple=FALSE)
#TITLE transforms a /des/ object into a list.
#DESCRIPTION
# Transforms a /des/ object into a list.
# More or less the reverse of \code{list2des}.
# When \code{simple} the shortened way is used.
#DETAILS
# Simple way means that the description is given
# as a character vector, not as a list. See the
# proposed examples.
#PKEYWORDS des
#KEYWORDS classes
#INPUTS
#{des} <<The /des/ to be transformed into a list.>>
#[INPUTS]
#{simple} <<indicates the way the list must be created.>>
#VALUE
# The generated list
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# des2list(rbsb.des1);
# des2list(rbsb.des1,TRUE);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_03_08
#REVISED 10_06_28
#--------------------------------------------
{
# checking
if (!valid8des(des)) {
str(des);
erreur(NULL,"This /des/ is not valid!");
}
# filling
if (simple) {
res <- list(des=des@name);
if (!isempty(des@orig)) {
res$des <- c(res$des,des@orig);
if (!isempty(des@time)) {
res$des <- c(res$des,des@time);
if (!isempty(des@defi)) {
res$des <- c(res$des,des@defi);
if (!isempty(des@role)) {
res$des <- c(res$des,des@role);
if (!isempty(des@comm)) {
res$des <- c(res$des,des@comm);
}
}
}
}
}
} else {
res <- vector("list",0);
if (!isempty(des@name)) { res$name <- des@name;}
if (!isempty(des@orig)) { res$orig <- des@orig;}
if (!isempty(des@time)) { res$time <- des@time;}
if (!isempty(des@defi)) { res$defi <- des@defi;}
if (!isempty(des@role)) { res$role <- des@role;}
if (!isempty(des@comm)) { res$comm <- des@comm;}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
char2des <- function(x)
#TITLE transforms, if necessary, a single character into a /des/ object
#DESCRIPTION
# when x is not a \code{character(1)} or a /des/ an error is issued
#DETAILS
#PKEYWORDS des
#KEYWORDS utilities
#INPUTS
#{x} <<name for the /des/ to be created, or an already existing /des/.>>
#[INPUTS]
#VALUE
# a /des/ object (not modfyied when x was already a /des/.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(char2des("toto"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_03_03
#REVISED 09_09_29
#--------------------------------------------
{
# checking
if ((!is.character(x)) &
(length(x)!=1) &
(!is(x,"des"))) {
erreur(x,"Must be 'character(1)' or a 'des' object!");
}
# returning
if (is(x,"des")) { res <- x;
} else {
res <- new("des",name=x,
orig=paste("created by",rbsb.msi),
time=now("d"));
}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
get8daf <- function(daf,wh=0,strict=FALSE,check=TRUE)
#TITLE returns the data frame associated to a /daf/
#DESCRIPTION
# Returns the data frame associated to a /daf/.
# The row numbers can be choosen with \code{wh}.
#DETAILS
# According to \code{daf@what} a different action is performed to
# get the data frame:
#{f} << The named \code{daf@valu} function is used without argument.>>
#{d} << The named \code{daf@valu} data frame is used.>>
#{t} << The named \code{daf@valu} file is read with read.table.>>
#{c} << The named \code{daf@valu} file is read with read.csv.>>
#{c2} << The named \code{daf@valu} file is read with read.csv2.>>
# For \code{t}, \code{c} or \code{c2} cases, \code{header=TRUE}
# and \code{comment.char='#'}.
#KEYWORDS datasets
#INPUTS
#{daf} <<The /daf/ to be read.>>
#[INPUTS]
#{wh} << numeric giving the numbers of the observations
# to be read. Zero means all observations.>>
#{strict} << When TRUE a fatal error is issued
# if some asked observations does not exist. If
# not the present ones are returned.>>
#{check} << Must the /daf/ object be checked?>>
#VALUE
# a data frame
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_05_11
#REVISED 10_03_08
#--------------------------------------------
{
# checking
if (check) {if (rbsb.mck) {valid8daf(daf);}}
if (rbsb.mck) {
check4tyle(wh,"integer",-1,message="These are supposed to be the asked row numbers");
if (min(wh) < 0) { erreur(wh,"Negative row number were asked.");}
}
# getting the values
if (daf@what == "t") {
res <- read.table(daf@valu,header=TRUE,comment.char="#");
}
#
if (daf@what == "c") {
res <- read.csv(daf@valu,header=TRUE,comment.char="#");
}
#
if (daf@what == "c2") {
res <- read.csv2(daf@valu,header=TRUE,comment.char="#");
}
#
if (daf@what == "d") {
coda <- paste("res <-",daf@valu);
eval(parse(text=coda));
}
#
if (daf@what == "f") {
coda <- paste("res <-" ,daf@valu,"()");
eval(parse(text=coda));
}
# possible observations
opo <- bc(nrow(res));
# defining and checking the asked observations
if (identical(wh,0)) { wh <- opo;}
prendre <- intersect(wh,opo);
if (strict) {
if (length(prendre) < length(wh)) {
erreur(list(opo,wh),"Some asked observations were not found");
}
}
# selecting the values
res <- res[prendre,,drop=FALSE];
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
char2vma <- function(cha,what=rbsb.vma["v"],
xsep=rbsb.sep1,nat="C")
#TITLE transforms a character into a vector (or matrix, or array)
#DESCRIPTION
# from a \code{character} vector, returns a vector, or a matrix, or
# an array of characters with possibly names, or dimames. The information
# can be supplied in different ways for each of the three possibilities.
# It is advised to try the proposed examples.
#DETAILS
# The processing is done in character mode but the result can be
# transformed into numerical or logical values with the help of argument \code{nat}.
# \cr
# In fact \code{rbsb.vma} coding is used for the argument \code{what}.
# This allows to easily modify the coding.
#PKEYWORDS
#KEYWORDS IO
#INPUTS
#{cha} << The character to transform.>>
#[INPUTS]
#{what} << Indicates which structure to return: either
# a vector, a matrix or an array.
# \cr \cr
# For vectors, the possibilities are c/C/u/v/U/V :
# \cr\code{rbsb.vma["c"]} for a no named character(1); collapsing
# is done with \code{rbsb.sep0}.
# \cr\code{rbsb.vma["C"]} for a no named character() of any length
# (components are separated with \code{xsep} whiwh are
# removed from the result); collapsing
# is done with \code{rbsb.sep0}.
# \cr\code{rbsb.vma["v"]} or \code{rbsb.vma["u"]} for a no named vector;
# \cr\code{rbsb.vma["V"]} for a named vector with
# all names before the values; then an even number
# of components must be provided.
# \cr\code{rbsb.vma["U"]} for a named vector with
# names interlaced with the value (name_i, value_i); then an even number
# of components must be provided.
# \cr \cr
# For matrices, the possibilities are m/n/o/p/M/N/O/P:
# \cr\code{rbsb.vma["m"]} for a no named matrix given by row, two adjacent rows
# being separated with \code{xsep} sequence, introduced as one of the
# component of \code{cha}, then for a 2x3 matrix, the length of \code{cha}
# will be 6+2 = 8.
# \cr\code{rbsb.vma["n"]} for a matrix with only the columns names. The expected sequence is
# the names of columns, then the values as for \code{rbsb.vma["m"]}; then for a 2x3
# matrix, the length of \code{cha} will be 3+1+8=12.
# \cr\code{rbsb.vma["o"]} for a matrix with only rows named. The expected sequence is
# name of row, values of rows... Then 2x3 will imply a length of 8+2=10.
# \cr\code{rbsb.vma["p"]} when names for columns and rows, in a mixed way... Then 2x3 will imply
# a length of 14.
# \cr
# When \code{rbsb.vma["M"],rbsb.vma["N"],rbsb.vma["O"],rbsb.vma["P"]},
# the same but the matrix will be transposed after
# being read; said in another way, the values are given by columns.
# \cr \cr
# For arrays, the possibilities are a/A/b/B:
# \cr\code{rbsb.vma["a"]} for a no named array, the dimensions, \code{xsep}, the values in
# the classical order (varying the first index the fastest). 2x3 will give
# a length of 2+1+6=9.
# \cr\code{rbsb.vma["A"]} for a dimnamed array, the dimensions, \code{xsep}, the dimnames of each
# dimension in the right order also separated and finished with \code{xsep}.
# 2x3 will gives a length of 2+1+2+1+3+1+6=16.
# \cr\code{rbsb.vma["b"]} for a named dimensions array, the dimensions, \code{xsep}, the names for the
# dimension in the right order not separated and finished with \code{xsep}.
# 2x3 will gives a length of 2+1+2+1+6=12.
# \cr\code{rbsb.vma["B"]} for a named and dimnamed array, the dimensions, \code{xsep}, the names for the
# dimension in the right order not separated and finished with \code{xsep}, then the dimnames separated
# before the values.
# 2x3 will gives a length of (2+1)+(2+1)+(2+1+3+1)+(6)=19.
# >>
#{xsep} << Character sequence used to separate the character vector into blocks
# giving information about the structure (see the examples).>>
#{nat} << Nature of the returned structure. Can be \code{C} for character, \code{N}
# for numeric or \code{L} for logical.>>
#VALUE a vector or a matrix or an array according to the inputs
#EXAMPLE
# rbsb3k("reset"); # For R checking convenience
## vectors
# char2vma(letters,"c");
# char2vma(letters,"C",xsep="e");
# char2vma(letters);
# char2vma(letters,"V");
# char2vma(letters,"u");
# char2vma(c(LETTERS,letters),rbsb.vma["V"]);
# char2vma(c("A","a","B","b","C","c"),rbsb.vma["U"]);
## matrices
# char2vma(c(1:3,"//",4:6),rbsb.vma["m"]);
# char2vma(c(1:3,"//",4:6),rbsb.vma["M"]);
# char2vma(c(LETTERS[1:3],"//",1:3,"//",4:6),rbsb.vma["n"]);
# char2vma(c(LETTERS[1:3],"//",1:3,"//",4:6),"N");
# char2vma(c("a",1:3,"//","b",4:6),"o");
# char2vma(c(c(LETTERS[1:3],"//","a",1:3,"//","b",4:6)),rbsb.vma["p"]);
## arrays
# char2vma(c(2:4,"//",1:24),"a");
# char2vma(c(2:4,"//","one","two","//",LETTERS[1:3],"//",
# letters[1:4],"//",1:24),"A");
# char2vma(c(2:4,"//","one","two","//",LETTERS[1:3],"//",
# letters[1:4],"//",1:24),"A",nat="N");
#REFERENCE
#SEE ALSO \code{vma2char}
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_03_28
#REVISED 10_08_13
#--------------------------------------------
{
# flexibility
if (isempty(cha)) { cha <- rbsb.cha0;}
# of use
ssep <- which(cha==xsep);
# checking
if (rbsb.mck) {
check4tyle(cha,rbsb.chara,-1,message="cha must be a character");
#
check4tyle(what,rbsb.chara,1,
message="what (character(1)) must indicate the type of desired output");
if (!(what %in% rbsb.vma)) {
erreur(what,"'what' not in the list of possible values...");
}
#
check4tyle(xsep,rbsb.chara,1,message="must indicate the character string of separation");
#
if (what %in% rbsb.vma[c("V","U")]) {
if ((length(cha) %% 2) != 0) {
erreur(list(cha,what),"Here the length of 'cha' must be even");
}
}
#
if (what %in% rbsb.vma[c("n","N","m","M","o","O")]) {
if (length(ssep) >= 1) {
nbc <- ssep[1] - 1;
nbr <- (length(cha)+1) / (nbc+1);
if ((nbr!=round(nbr)) | (length(cha) != (nbc*nbr+nbr-1))) {
erreur(list(what,length(cha),nbc,nbr),"Dimensions not consistent");
}
}
}
#
if (what %in% rbsb.vma[c("p","P")]) {
if (length(ssep) >= 1) {
nbc <- ssep[1] + 1;
X <- 2 + length(cha);
if ((X %% nbc) != 0) {
erreur(list(what,length(cha),nbc),"Dimensions not consistent");
}
}
}
#
if (what %in% rbsb.vma[c("a","A","b","B")]) {
# an array must be returned
if (length(ssep)==0) {
erreur(list(cha,xsep),"For arrays, dims must be provided");
}
didi <- cha[1:(ssep[1]-1)];
didi <- as.numeric(didi);
if (sum(is.na(didi))>0) {
erreur(list(cha,xsep),"Dimensions are not numeric !");
}
if (any(didi<0)) {
erreur(didi,"Negative dimensions were provided");
}
if (any(didi!=round(didi))) {
erreur(didi,"Non integer dimensions were provided");
}
X <- length(didi) + 1 + prod(didi);
if (what %in% rbsb.vma[c("A","B")]) { X <- X + sum(didi) + length(didi); }
if (what %in% rbsb.vma[c("b","B")]) { X <- X + length(didi) + 1; }
if (length(cha) != X) {
erreur(list(cha,what,xsep),"Inconsistency for an array");
}
}
#
check4tyle(nat,rbsb.chara,1,message="'nat' must be a character(1)");
}
#
res <- rbsb.cha0;
#
if (what %in% rbsb.vma["c"]) {
# a single character must be returned
# rbsb.sep0 is used as collapsor
res <- paste(cha,collapse=rbsb.sep0);
}
#
if (what %in% rbsb.vma["C"]) {
# a character must be returned
# rbsb.sep0 is used as separator
res <- paste(cha,collapse=rbsb.sep0);
res <- strsplit(res,xsep,fixed=TRUE)[[1]];
if (length(res)>1) { for (ii in 2:length(res)) {
res[ii ] <- form3decadre(res[ii ],rbsb.sep0,"",1);
res[ii-1] <- form3decadre(res[ii-1],"",rbsb.sep0,1);
}}
}
#
if (what %in% rbsb.vma[c("v","V","u","U")]) {
# a vector must be returned
if (what %in% c(rbsb.vma[c("v","u")])) {
res <- cha;
} else {
nb <- floor(length(cha)/2);
if (what == rbsb.vma["V"]) { nam <- rep(c(TRUE,FALSE),each=nb);
} else { nam <- rep(c(TRUE,FALSE),nb); }
res <- cha[!nam];
names(res) <- cha[nam];
}
}
#
if (what %in% rbsb.vma[c("m","M","n","N","o","O","p","P")]) {
# a matrix must be returned
nbc <- ssep[1] - 1;
cha <- c(cha,xsep);
if (what %in% c(rbsb.vma[c("p","P")])) {
cha <- c(" ",cha);
}
if (what %in% rbsb.vma[c("p","P")]) { add <- 1;
} else { add <- 0; }
cha <- matrix(cha,ncol=nbc+1+add,byrow=TRUE);
cha <- cha[,-ncol(cha),drop=FALSE];
if (what %in% rbsb.vma[c("m","M")]) {
res <- cha;
}
if (what %in% rbsb.vma[c("n","N")]) {
res <- cha[-1,,drop=FALSE];
dimnames(res) <- list(NULL,cha[1,,drop=FALSE]);
}
if (what %in% rbsb.vma[c("o","O")]) {
res <- cha[,-1,drop=FALSE];
dimnames(res) <- list(cha[,1,drop=FALSE],NULL);
}
if (what %in% rbsb.vma[c("p","P")]) {
res <- cha[-1,-1,drop=FALSE];
dimnames(res) <- list(cha[-1,1,drop=FALSE],cha[1,-1,drop=FALSE]);
}
if (what %in% rbsb.vma[c("M","N","O","P")]) {
res <- t(res);
}
}
#
if (what %in% rbsb.vma[c("a","A","b","B")]) {
if (length(ssep) == 0) { erreur(cha,"For array, dimensions must be provided");}
# an array must be returned
didi <- cha[1:(ssep[1]-1)];
didi <- as.numeric(didi);
nbdi <- length(didi);
#
if (what == rbsb.vma["a"]) { vvv <- cha[-(1:ssep[1])];}
if (what == rbsb.vma["A"]) { vvv <- cha[-(1:ssep[1+nbdi])];}
if (what == rbsb.vma["b"]) { vvv <- cha[-(1:ssep[2])];}
if (what == rbsb.vma["B"]) { vvv <- cha[-(1:ssep[2+nbdi])];}
#
res <- array(vvv,dim=didi);
#
if (what %in% rbsb.vma[c("A","B")]) {
ndi <- vector("list",0);
for (jj in bf(didi)) {
jjj <- jj + (what == rbsb.vma["B"]);
if (ssep[jjj+1]-ssep[jjj]>1) {
ndi[[jj]] <- cha[(ssep[jjj]+1):(ssep[jjj+1]-1)];
}
}
dimnames(res) <- ndi;
}
if (what %in% rbsb.vma["b"]) {
ndi <- vector("list",0);
for (jj in bf(didi)) {
ndi[[jj]] <- 1:didi[jj];
}
dimnames(res) <- ndi;
}
if (what %in% rbsb.vma[c("b","B")]) {
names(dimnames(res)) <- cha[(ssep[1]+1):(ssep[2]-1)];
}
}
# transtyping
if (nat %in% c("N","L")) {
rrr <- as.numeric(res);
if (nat == "L") { rrr <- as.logical(rrr);}
attributes(rrr) <- attributes(res);
res <- rrr;
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
vma2char <- function(x,xsep=rbsb.sep1)
#TITLE transforms a vector (or matrix, or array) into a character
#DESCRIPTION
# from a vector, or a matrix, or
# an array, returns a \code{character} vector. More or less the
# inverse function of \code{char2vma}.
#DETAILS
# When some dimnames exist, the possible missing
# ones will be added.
#PKEYWORDS
#KEYWORDS IO
#INPUTS
#{x} << The object to transform.>>
#[INPUTS]
#{xsep} << \code{character(1)} to be use for the separations.>>
#VALUE a list with two components: \code{[[1]]} the coded character vector and
# \code{[[2]]} the type according to \code{char2vma}.
#EXAMPLE
# rbsb3k("reset"); # For R checking convenience
## vectors
# vma2char(letters);
# x <- letters; names(x) <- LETTERS;
# xx <- vma2char(x);
# char2vma(xx[[1]],xx[[2]]);
# vma2char(character(0));
## matrices
# x <- matrix(1:20,4);
# vma2char(x);
# dimnames(x) <- list(letters[1:4],LETTERS[1:5]);
# vma2char(x);
# x1 <- matrix(NA,3,0);
# xx1 <- vma2char(x1);
# char2vma(xx1[[1]],xx1[[2]]);
# dimnames(x1) <- list(c("i","ii","iii"),NULL);
# xx1 <- vma2char(x1);
# char2vma(xx1[[1]],xx1[[2]]);
## arrays
# x <- array(1:24,2:4);
# vma2char(x);
# dimnames(x) <- list(1:2,c("i","ii","iii"),c("I","II","III","IV"));
# vma2char(x,xsep="|||");
# x0 <- array(NA,c(3,0,2));
# dimnames(x0) <- list(1:3,NULL,c("i","ii"));
# xx0 <- vma2char(x0);
# char2vma(xx0[[1]],xx0[[2]]);
#REFERENCE
#SEE ALSO \code{vma2char}
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_03_29
#REVISED 10_06_29
#--------------------------------------------
{
# checking
if (rbsb.mck) {
#
check4tyle(xsep,rbsb.chara,1,message="must indicate the character string of separation");
#
if (!is.vector(x) &
!is.matrix(x) &
!is.array(x)) {
erreur(class(x),"'x' must be a vector or a matrix or an array!");
}
}
#
res <- vector("list",2);
names(res) <- c("character","type");
#
if (is.array(x)&(!is.matrix(x))) {
# dealing with an array
res[[1]] <- c(as.character(dim(x)),xsep);
if (is.null(dimnames(x))) {
res[[2]] <- rbsb.vma["a"];
} else {
nna <- dimnames(x);
for (hh in bf(nna)) {
if (is.null(nna[[hh]])) {
nna[[hh]] <- bc(dim(x)[hh]);
}
}
if (is.null(names(nna))) {
for (ii in bf(nna)) {
res[[1]] <- c(res[[1]],nna[[ii]],xsep);
}
res[[2]] <- rbsb.vma["A"];
} else {
res[[1]] <- c(res[[1]],names(nna),xsep);
for (ii in bf(nna)) {
res[[1]] <- c(res[[1]],nna[[ii]],xsep);
}
res[[2]] <- rbsb.vma["B"];
}
}
res[[1]] <- c(res[[1]],as.character(x));
} else {
if (is.matrix(x)) {
# dealing with a matrix
if (is.null(dimnames(x))) {
res[[1]] <- character(0);
for (ii in bc(nrow(x))) {
res[[1]] <- c(res[[1]],x[ii,],xsep);
}
res[[1]] <- res[[1]][-length(res[[1]])];
res[[2]] <- rbsb.vma["m"];
} else {
nna <- dimnames(x);
for (hh in bf(nna)) {
if (is.null(nna[[hh]])) {
nna[[hh]] <- bc(dim(x)[hh]);
}
}
res[[1]] <- c(as.character(nna[[2]]),xsep);
for (ii in bc(nrow(x))) {
res[[1]] <- c(res[[1]],nna[[1]][ii],as.character(x[ii,]),xsep);
}
res[[1]] <- res[[1]][-length(res[[1]])];
res[[2]] <- rbsb.vma["p"];
}
} else {
# dealing with a simple vector
if (is.null(names(x))) {
res[[1]] <- as.character(x);
res[[2]] <- rbsb.vma["v"];
} else {
res[[1]] <- c(names(x),as.character(x));
res[[2]] <- rbsb.vma["V"];
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
is8rbsblist <- function(lili)
#TITLE checks whether a list is rbsb-compatible list or not
#DESCRIPTION
# A rbsb-list must satisfy the following two properties:
#{i} <<All components and sub-components being named.>>
#{ii} <<All components and sub-components being either a list
# or a character vector/matrix/array (vma components are called
# leafs of the rbsb-list).>>\cr
# Only such lists are handled by \code{list2file} and \code{file2list}
# functions.
#DETAILS
#PKEYWORDS
#KEYWORDS IO
#INPUTS
#{lili} << The list structure to be checked.>>
#[INPUTS]
#VALUE
# TRUE/FALSE according to the case.
# Also a global variable \code{rbsb.is8rbsblist} is created
# to give the result through a \code{des} object.
#EXAMPLE
# rbsb3k("reset");
# is8rbsblist(rbsb.lis1);
# is8rbsblist(list(rbsb.lis1));
# print(rbsb.is8rbsblist,what="c");
# is8rbsblist(list(rbsb.lis1,nu=NULL));
# print(rbsb.is8rbsblist,what="c");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_04_19
#REVISED 10_04_20
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4tyle(lili,"list",-1,message="lili must be a list");
}
# exploring the list
eee <- explore8list(lili);
# checking the presence on unamed components
# and the types of the list
comment <- rbsb.cha0;
for (ii in bc(nrow(eee))) {
if ((eee[ii,"name"]=="<NA>")|(eee[ii,"name"]=="")) {
comment <- c(comment,
paste("The component",eee[ii,"numbers"],
"has got no name:",
paste("'",eee[ii,"names"],"'",sep=""))
);
}
coco <- get8listcomp(lili,eee[ii,,drop=FALSE]);
if (length(coco) > 0) { coco <- coco[[1]];}
if (!(is.list(coco) |
is.numeric(coco) |
is.character(coco) |
is.matrix(coco) |
is.array(coco))) {
comment <- c(comment,
paste("The component (",eee[ii,"numbers"],
") with name: '",eee[ii,"names"],
"is not list/vector/matrix/array")
);
}
}
# preparing the result
if (isempty(comment)) {
res <- TRUE;
dede <- new("des",name="result",
orig="from is8rbsblist",
time=now(),
comm="This was a good rbsb-list.");
} else {
res <- FALSE;
dede <- new("des",name="result",
orig="from is8rbsblist",
time=now(),
comm=c("This was NOT a good rbsb-list.",
comment));
}
# producing the answer
assign("rbsb.is8rbsblist",dede,pos=".GlobalEnv");
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
###########################################
########
#((((((( NEW S4 CLASS nom
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8nom <- function(object)
#TITLE checks a /nom/
#DESCRIPTION
# This function checks /nom/ objects
#DETAILS
# It is the validity method for /nom/ objects.
#KEYWORDS classes
#INPUTS
#{object} <<The nom object to be validated.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_09_30
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="nom") {
erreur(NULL,paste("This object is not of class 'nom' but '",class(object),"'",sep=""));
}
res <- character(0);
if (!("x" %in% slotNames(object))) {
res <- c(res,"This supposed /nom/ has no slot @x!");
return(res);
}
#
# except when empty a named list is expected for @x
if (length(object@x)>0) {
if (is.null(names(object@x))) {
res <- c(res,"slot x of nom must be a NAMED list");
}
}
# no duplicatd node names
if (sum(duplicated(names(object@x)))>0) {
res <- c(res,"Node names must be unique");
}
# no empty node names
if ("" %in% names(object@x)) {
res <- c(res,"Node names must not be empty");
}
# for the variable names
for (jbd in bf(names(object@x))) {
# at least one variable
if (length(object@x[[jbd]])==0) {
res <- c(res,"A node (jbd) has got no variable name, '' must be introduced at minimum");
}
# no duplication within a node
if (sum(duplicated(object@x[[jbd]]))>0) {
res <- c(res,"Some of these variable names are duplicated");
}
# no empty node except when unique
if (("" %in% object@x[[jbd]])&(length(object@x[[jbd]])>1)) {
res <- c(res,"Variable names must not be empty except when the variable is unique");
}
}
#
if (length(res)== 0) { res <- TRUE;
} else { erreur(res,w=rbsb.mwa);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
setClass("nom", representation(
x="list" # list of variable names of each node, the component names
# are the node names when there is no variable name,
# must be "" NOT character(0) for the length giving
# giving the number of variables in any cases...
),
prototype(x=vector("list",0)),
validity=valid8nom
);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8nom <- function(x,...,what="v",type=0)
#TITLE prints the node-variable names
#DESCRIPTION
# prints the node-variable names of x (a 'nom' object)
#DETAILS
#KEYWORDS print
#PKEYWORDS print
#INPUTS
#{x} <<nom object>>
#[INPUTS]
#{\dots} <<Further arguments to be passed to the print function.>>
#{what} << what to print ('v'=node:variable names;
# 'nv'=node[variable] names;
# 'n' only node names)
#{type} << type of printing:
# (0) everything on the same line;
# (1) a node, a line.>>
#VALUE
# nothing a printing is issued
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.nom2);
# print(rbsb.nom2,what='nv');
#REFERENCE
#FUTURE
#SEE ALSO
#CALLING
#COMMENT
#AUTHOR J.-B. Denis
#CREATED 09_04_08
#REVISED 10_06_10
#--------------------------------------------
{
# some checks
if (rbsb.mck) {
#
che <- valid8nom(x);
if (!identical(che,TRUE)) {
erreur(che,"This /nom/ is not valid");
}
#
types <- 0:1;
if (!(type %in% types)) {
erreur(list(types,type),"Bad argument");
}
#
forma <- c("v","n","nv");
if (!(what %in% forma)) {
erreur(list(forma,what),"Bad argument");
}
}
#
if (nbnv(x) > 0) {
for (ii in names(x@x)) {
if (what=="n") {
cat(" ",ii);
}
if (what=="v") {
cat(" ",ii);
cat(form3liste(x@x[[ii]],none=character(0),OPA="[",CPA="]",opa="",cpa="",sep="|"));
}
if (what=="nv") {
cat(" ");
if (identical(x@x[[ii]],"")) { cat(ii);
} else {
cat(form3liste(x@x[[ii]],none=character(0),OPA="",CPA="",opa=paste(ii,"[",sep=""),cpa="]",sep=","));
}
}
if (type==1) { if (ii!=names(x@x)[nbnv(x)]) { cat("\n");}}
}
}
cat("\n");
#
# returning
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
length8nom <- function(x)
#TITLE returns the length of a 'nom' object
#DESCRIPTION
# provides the number of nodes of a \code{/nom/}.
#DETAILS
#KEYWORDS misc
#PKEYWORDS
#INPUTS
#{x}<<the 'nom' object to be measured.>>
#[INPUTS]
#VALUE
# The number of nodes in 'x'
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# length(rbsb.nom1);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_29
#REVISED 09_04_29
#--------------------------------------------
{
# returning
length(x@x);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
setMethod("print",signature(x = "nom"), print8nom);
setMethod("length",signature(x = "nom"), length8nom);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
x2nom <- function(x)
#TITLE returns the "nom" slot of an object
#DESCRIPTION
# when 'x' is a 'nom' object returns it. Else
# checks if \code{x@nom} exists and returns it, if not
# a fatal error is issued.
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{x} <<the bn/gn/dn/gn/.. or nom object>>
#[INPUTS]
#VALUE
# a 'nom' object
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# identical(rbsb.nom0,x2nom(rbsb.nom0));
#COMMENT
#AUTHOR J.-B. Denis
#CREATED 09_04_20
#REVISED 09_09_29
#--------------------------------------------
{
if (!is(x,"nom")) {
if (!("nom" %in% slotNames(x))) {
str(x);
erreur(slotNames(x),"'x' is not a 'nom' object or does not have got such a slot!");
}
x <- x@nom;
}
# returning
x;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
char2nom <- function(nova)
#TITLE transforms a character into a 'nom' object
#DESCRIPTION
# returns a \code{/nom/} whose names/variables comes from \code{nova}.
# Repetitions are possible and eliminated.
#DETAILS
# nodes and variables/nodes are sorted.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nova} <<character.>>
#[INPUTS]
#VALUE
# a 'nom' object with nodes possibly comprising covariables
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print.default(char2nom(LETTERS[1:4]));
# print(char2nom(c("C[b]","A","B[one]","C[b]","C[a]","B[two]")));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 10_07_06
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4tyle(nova,"character",-1);
}
## preparing
nova <- sort(unique(nova));
nono <- nv2nod(nova);
nova <- nv2var(nova);
## getting the x slot
no <- sort(unique(nono));
# first the node names
xx <- as.list(rep("",length(no)));
names(xx) <- no;
# second the variate names
for (nn in no) {
ou <- which(nn==nono)
vv <- nova[ou];
xx[[nn]] <- sort(vv);
}
res <- new("nom",x=xx);
if (rbsb.mck) {check4valid(valid8nom(res));}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nom2char <- function(nom,of="v",sort=FALSE)
#TITLE transforms a /nom/ into a character
#DESCRIPTION
# returns a character of the variables or node from a \code{/nom/}.
#DETAILS
# Notice that \code{char2nom(nom)} is equivalent to \code{nv2ion(0,nom,"v")@nvn}.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nom} <<The \code{nom} object to be transformed.>>
#[INPUTS]
#{of} <<'v' to return the set of variables; 'n' to return the set
# of involved nodes.>>
#{sort} <<Must the nodes and names be sorted?>>
#VALUE
# a \code{character}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nom2char(rbsb.nom3);
# nom2char(rbsb.nom3,"n");
#REFERENCE
#SEE ALSO nom2char
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_06
#REVISED 10_09_27
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
if (!(of %in% c("v","n"))) {
erreur(of,"Must be 'v' for 'variables' or 'n' for 'nodes'");
}
}
## preparing
if (of == "n") {
# node names
res <- names(nom@x);
} else {
# variable names
res <- character(0);
for (ii in bf(nom@x)) {
nn <- names(nom@x)[ii];
if(isvide(nom@x[[ii]])) {
res <- c(res,nn);
} else {
res <- c(res,paste(nn,rbsb.cpt["variables","opening"],
nom@x[[ii]],
rbsb.cpt["variables","closing"],sep=""));
}
}
}
#
if (sort) { res <- sort(res);}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
list2nom <- function(lili)
#TITLE transforms a list into a /nom/
#DESCRIPTION
# simply returns \code{nom} with its unique slot \code{@x}
# being equal to \code{lili}. This
# function was introduced for consistency with other
# objects and to prepare future evolutions
#DETAILS
# According to \code{rbsb.mck} the produced object is checked.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{lili} <<The \code{list} object to be transformed.>>
#[INPUTS]
#VALUE
# The resulting \code{nom}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# list2nom(rbsb.nom3@x);
#REFERENCE
#SEE ALSO nom2list
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_07
#REVISED 10_07_07
#--------------------------------------------
{
## preparing
res <- new("nom",x=lili);
# checking
if (rbsb.mck) {
check4valid(valid8nom(res));
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nom2list <- function(nom)
#TITLE transforms a /nom/ into a list
#DESCRIPTION
# simply returns \code{nom@x} which is a list. This
# function was introduced for consistency with other
# objects and to prepare future evolutions
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nom} <<The \code{nom} object to be transformed.>>
#[INPUTS]
#VALUE
# The resulting \code{list}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nom2list(rbsb.nom3);
#REFERENCE
#SEE ALSO list2nom
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_07
#REVISED 10_07_07
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
}
## preparing
res <- nom@x;
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
sort8nom <- function(nom,by="Aa")
#TITLE sorts a /nom/ according to various ways
#DESCRIPTION
# Nodes and variables of the \code{nom} are sorted
# according the alphabet, the number of variables.
#DETAILS
# Compatible criteria can be used simultaneously.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nom} <<The \code{nom} object to be sorted.>>
#[INPUTS]
#{by} <<A \code{character(1)} indicating the kind of sorting
# by the letters in it. \code{a} for sorting the variables
# within the node in alphabetical order. \code{A} for the nodes
# and/or \code{S} with respect to their numbers of variates.>>
#VALUE
# The resulting \code{nom}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# sort8nom(rbsb.nom3,"S");
# print(sort8nom(rbsb.nom7,"Aa"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_07
#REVISED 10_07_08
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(by,"character",1,message="'by' must be 'character(1)'");
}
## preparing
on <- bf(nom@x);
if (expr3present("S",by)) { on <- order(sapply(nom@x,length));}
if (expr3present("A",by)) { on <- order(names(nom@x));}
res <- vector("list",length(nom@x));
names(res) <- names(nom@x)[on];
al <- expr3present("a",by);
for (ii in bf(nom@x)) {
iii <- names(res)[ii];
if (!al) { res[[ii]] <- nom@x[[iii]];
} else { res[[ii]] <- sort(nom@x[[iii]]);}
}
res <- new("nom",x=res);
if (rbsb.mck) { check4valid(valid8nom(res));}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
compare8nom <- function(noma,nomb,level="v")
#TITLE compares two /nom/s
#DESCRIPTION
# compares two /nom/s either at the node or
# at the variable level.
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{noma} <<The first \code{nom} to be compared.>>
#{nomb} <<The second \code{nom} to be compared.>>
#[INPUTS]
#{level} <<'v' or 'n' to indicate if the comparaison
# must be made at the 'variable' or 'node' level.>>
#VALUE
# A list of three /nom/ named \code{$a_b}, \code{$b_a} and
# \code{$a.b} giving the respectively the set differences and the
# intersection of the choosen items.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# compare8nom(rbsb.nom2,rbsb.nom3);
# compare8nom(rbsb.nom2,rbsb.nom3,"n");
# compare8nom(rbsb.nom5,rbsb.nom3);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_08
#REVISED 10_07_08
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(noma));
check4valid(valid8nom(nomb));
check4tyle(level,"character",1,message="'level' must be 'character(1)'");
if (!(level %in% c("v","n"))) {
erreur(level,"'level' must be 'v' or 'n'");
}
}
# taking care of the level
if (level == "n") {
noma <- nom2nom(noma);
nomb <- nom2nom(nomb);
}
# making the set operations
itema <- nom2char(noma);
itemb <- nom2char(nomb);
res <- vector("list",0);
res[["a_b"]] <- char2nom(setdiff(itema,itemb));
res[["b_a"]] <- char2nom(setdiff(itemb,itema));
res[["a.b"]] <- char2nom(intersect(itema,itemb));
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nom2nom <- function(nom,what="n")
#TITLE transform a /nom/.
#DESCRIPTION
# Reduces a /nom/ to its node.
#DETAILS
# For the moment, this is the only possiblility;
# further on more ideas can occur.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nom} <<The \code{nom} object to be transformed.>>
#[INPUTS]
#{what} <<\code{character(1)} indicating the kind of
# transformation. \code{n} for removing all the
# the possible variables, leaving only the nodes.>>
#VALUE
# The resulting \code{nom}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(nom2nom(rbsb.nom7));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_08
#REVISED 10_07_08
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(what,"character",1,message="'by' must be 'character(1)'");
}
## preparing
if (expr3present("n",what)) {
res <- lapply(bf(nom@x),function(x){"";});
names(res) <- names(nom@x);
res <- new("nom",x=res);
}
# checking
if (rbsb.mck) { check4valid(valid8nom(res));}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv2nod <- function(vvn)
#TITLE transforms complete variable names into node names
#DESCRIPTION
# No ckeck is made about the existence of the node names
#DETAILS
# the syntax analysis is minimal, looking for a square bracket
# and eliminating evething from that point !
#KEYWORDS misc
#PKEYWORDS node
#INPUTS
#{vvn} <<vector of variable names>>
#[INPUTS]
#VALUE
# vector of deduced node names
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv2nod("aa"); # "aa" is returned
# nv2nod(c("a[e]","az[ee]","b")); # c("a","az","b") is returned
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# This function has been added to get the parents of an alk
# whithout reference to a gn/bn.
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_01_15
#REVISED 10_09_22
#--------------------------------------------
{
sep <- rbsb.cpt["variables","opening"];
un <- function(x) {x[1];}
res <- sapply(strsplit(vvn,sep,fixed=TRUE),un);
if (length(res) == 0) { res <- character(0);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv2var <- function(nvn)
#TITLE returns the variable name from a node[variable] name
#DESCRIPTION
# Just removing the node name and square brackets.
# \code{nvn} can be a vector. In case there is no variable name,
# the standard "" is returned
#DETAILS
# Variable name can be numeric and is returned as such
#KEYWORDS misc
#PKEYWORDS name var
#INPUTS
#{nvn} << character of the complete variable name>>
#[INPUTS]
#VALUE
# variable name without node name
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv2var(c("A[5]","B"));
#REFERENCE
#SEE ALSO va3va
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 08_01_03
#REVISED 10_09_22
#--------------------------------------------
{
sop <- rbsb.cpt["variables","opening"];
scl <- rbsb.cpt["variables","closing"];
#
res <- character(0);
for (i in bf(nvn)) {
nv <- nvn[i];
if (length(grep(sop,nv,fixed=TRUE)) == 0) {
# no variable name
res <- c(res,"");
} else {
if ((grep(sop,nv,fixed=TRUE) != 1) ||
(grep(scl,nv,fixed=TRUE) != 1)) {
cat("you provide (",nv,") as complete node[variable] name\n",sep="");
erreur(NULL,"BUT it does not comprise the corresponding parenthesis!");
}
nv <- strsplit(nv,sop,fixed=TRUE)[[1]][2];
nv <- strsplit(nv,scl,fixed=TRUE)[[1]][1];
res <- c(res,nv);
}
}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nbnv <- function(x,what=-1)
#TITLE number of nodes/variables for a /nom/ or an /object@nom/
#DESCRIPTION
# According to 'what', returns the number of
# nodes/variables for a \code{nom} or an object
# comprising a slot \code{@nom}.
#DETAILS
# no check is performed.
#KEYWORDS misc
#PKEYWORDS node nb gn dn nom
#INPUTS
#{x} <<the bn/gn/dn/gn or nom object>>
#[INPUTS]
#{what} <<
# -1: returns the number of nodes
# 0: returns the total number of variables
# i: returns the number of variables of the i-th node.
# (For convenience 'n' is translated as -1 and 'v' is
# translated as 0).>>
#VALUE
# The number of nodes or variables, accordingly to what
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nbnv(rbsb.nom2); # number of nodes
# nbnv(rbsb.nom2,0); # number of variates
#COMMENT
# Remember that in most cases the number of
# variables of a dn associated to a bn is one
# more due to the scoring ">?<" variable.\cr
# This function is a fusion of former nbnd and
# nbva functions.
#AUTHOR J.-B. Denis
#CREATED 07_06_13
#REVISED 09_11_25
#--------------------------------------------
{
#
# checking
if (rbsb.mck) {
check4tyle(what,c("integer","character"),1,message="Bad 'what' in 'nbnv'!");
}
x <- x2nom(x);
if (what=="n") { what <- -1;}
if (what=="v") { what <- 0;}
if (!is.numeric(what)) { erreur(what,"'what' is not acceptable!");}
if (what==-1) {
res <- length(names(x@x));
} else {
nvs <- sapply(x@x,length);
if (length(nvs)==0) {nvs <- numeric(0);}
if (what==0) {
res <- sum(nvs);
} else {
if ((what < -1)|(what > length(nvs))) {
erreur(list(x,what),"'what' is not a node number of the nom 'x'");
} else {
res <- nvs[what];
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
and4nom <- function(nom,nod,var="")
#TITLE adds one node to a /nom/
#DESCRIPTION
# returns \code{nom} after adding it a new node.
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom node
#INPUTS
#{nom} <<The /nom/ to be completed.>>
#{nod} <<Name for the new node (character(1)).>>
#[INPUTS]
#{var} <<Name(s) for the variable of the new node.>>
#VALUE
# The /nom/ completed
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.nom2);
# print(and4nom(rbsb.nom2,"D","z"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 09_05_06
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(nod,"character", 1,message="The node name (only one) was expected.");
check4tyle(var,"character",c(1,Inf),message="The variable name(s) was expected [At least one].");
if (nod %in% nanv(nom,"n")) {
erreur(list(nom,nod),"The node you proposed already exists.");
}
if (length(unique(var))!=length(var)) {
erreur(var,"You proposed duplicated variable names for the same node.");
}
}
# addition
nom@x[[nod]] <- var;
# returning
nom;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
rmnd4nom <- function(nom,nod)
#TITLE removes one node to a /nom/
#DESCRIPTION
# removes one (and only one) node to a \code{/nom/}.
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom node
#INPUTS
#{nom} <<The /nom/ to be restricted.>>
#{nod} <<Name of the name to be removed (character(1)).>>
#[INPUTS]
#VALUE
# The reducede /nom/
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rmnd4nom(rbsb.nom2,"A"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 09_05_06
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(nod,"character", 1,message="The node name (only one) was expected.");
if (!(nod %in% nanv(nom,"n"))) {
erreur(list(nom,nod),"The node you proposed does not exist in that /nom/.");
}
}
# removing
qui <- which(names(nom@x)!=nod);
nom@x <- nom@x[qui];
# returning
nom;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nanv <- function(x,what=-1)
#TITLE returns the names of nodes/variables of x2nom(nom)
#DESCRIPTION
# According to 'what', returns the names of
# nodes/variables for \code{nom} or \code{nom@nom}.
#DETAILS
# As it is a very basic function, no check is
# made about the arguments.
#KEYWORDS misc
#PKEYWORDS nom node variable
#INPUTS
#{x} <<the object to consider>>
#[INPUTS]
#{what} <<
# -2: returns all names of the variables (without the node name)
# -1: returns the names of the nodes
# 0: returns all names of the variables (including the node name)
# i: returns the names of the variables of the i-th node.
# (For convenience 'n' is translated as -1 and 'v' is
# translated as 0).>>
#VALUE
# The names of nodes or variables, accordingly to \code{what}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nanv(rbsb.nom2) # node names
# nanv(rbsb.nom2,0) # node[variable] names
# nanv(rbsb.nom2,-2) # variable names
#COMMENT
# Remember that in most cases the number of
# variables of a dn associated to a bn is one
# more due to the scoring ">?<" variable.\cr
# This function is consistent with nbnv.
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 09_11_25
#--------------------------------------------
{
# no checking
#
sep <- rbsb.cpt["variables",];
#
x <- x2nom(x);
if (what=="n") { what <- -1;}
if (what=="v") { what <- 0;}
if (!is.numeric(what)) { erreur(what,"'what' is not acceptable!");}
if (what==-1) {
res <- names(x@x);
} else {
if (what==0) {
res <- character(0);
for (ii in bf(x@x)) {
if (all(x@x[[ii]]=="")) {
res <- c(res,names(x@x)[ii]);
} else {
res <- c(res,
paste(names(x@x[ii]),
sep[1],
x@x[[ii]],
sep[2],
sep="")
);
}
}
} else {
if (what==-2) {
res <- character(0);
for (ii in bf(x@x)) {
res <- c(res,x@x[[ii]]);
}
} else {
if ((what < -1)|(what > length(x@x))) {
erreur(list(x,what),"'what' is not a node number of the nom 'x'");
} else {
ii <- what;
if (all(x@x[[ii]]=="")) {
res <- names(x@x)[ii];
} else {
res <- paste(names(x@x[ii]),
sep[1],
x@x[[ii]],
sep[2],
sep="");
}
}
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv3nom <- function(na,nom)
#TITLE detects the existence of names into x2nom(nom)
#DESCRIPTION
# Detects the existence of 'na' as a valid node names or
# a valid variable names included into \code{nom}
# or \code{nom@nom}.
#DETAILS
# In case of identical variable and node names, the node
# will be retained: \code{nv3nom("a",new("nom",x=list(a="a")))}
# returns 1, not -1.
#KEYWORDS misc
#PKEYWORDS node
#INPUTS
#{na} <<name vector to be looked for>>
#{nom} <<nom object to make the correspondence.>>
#[INPUTS]
#VALUE
# a named (with \code{na}) numeric vector of \code{length(na)}.
# Its values are:
# -i when a variable name of the ith node
# 0 when no correspondance;
# 1 when a node name with variable(s);
# 2 when a node[variable] name;
# 3 when a node name without variable.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv3nom(c("C[1]","C[10]","2","C","B","a"), rbsb.nom3);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_16
#REVISED 10_09_22
#--------------------------------------------
{
# transforming
nom <- x2nom(nom);
# some checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(na,rbsb.chara,-1);
}
# preparing
res <- rep(0,length(na));
names(res) <- na;
vari <- nanv(nom,-2);
node <- nanv(nom,-1);
nova <- nanv(nom, 0);
if (length(nom)>0) {
# looking for single variables
var <- which(apply(outer(na,vari,"=="),1,sum)==1);
res[var] <- -1;
# looking for nodes
nod <- which(apply(outer(na,node,"=="),1,sum)==1);
res[nod] <- 1;
# looking for node[variable]
nov <- which(apply(outer(na,nova,"=="),1,sum)==1);
res[nov] <- 2
# refining the nodes and variables alone
for (ii in bf(res)) {
nam <- names(res)[ii];
if (res[ii] == 1) {
if (all(nom@x[[nam]]=="")) {
# this is a single node
res[ii] <- 3;
}
}
if (res[ii] == -1) {
# a single variable looking for its node
vou <- which(nam==vari)[1];
nou <- nv2nod(nova)[vou];
res[ii] <- - which(nou==names(nom@x));
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8ion <- function(object)
#TITLE checks a /ion/
#DESCRIPTION (ba)
# This function checks /ion/ objects
#DETAILS
# It is the validity method for /ion/ objects.
#KEYWORDS classes
#INPUTS
#{object} <<The ion object to be validated.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_01
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="ion") {
erreur(NULL,paste("This object is not of class 'ion' but '",class(object),"'",sep=""));
}
res <- character(0);
#
# each slot must have the same lenght
nl <- length(object@nn);
if (length(object@vn) != nl) { res <- c(res,"length of @vn is different from this of @nn");}
if (length(object@nvn)!= nl) { res <- c(res,"length of @nvn is different from this of @nn");}
if (length(object@nk) != nl) { res <- c(res,"length of @nk is different from this of @nn");}
if (length(object@ij) != nl) { res <- c(res,"length of @ij is different from this of @nn");}
if (length(object@vk) != nl) { res <- c(res,"length of @vk is different from this of @nn");}
#
# all variate names must be different
if (length(object@nvn) != length(unique(object@nvn))) {
res <- c(res,paste(object@nvn,"repetitions between variate names"));
}
#
if (length(res)== 0) { res <- TRUE;
} else { erreur(res,w=rbsb.mwa);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
# see the comment into nv2ion for some explanation...
#
setClass("ion", representation(
nn="character", # node names
vn="character", # variable names
nvn="character", # node[variable] names
nk="numeric", # node numbers
ij="numeric", # variable numbers within node
vk="numeric", # variable numbers
iden="character" # identification of the inputs
),
prototype(nn=character(0),vn=character(0),nvn=character(0),
nk=numeric(0),ij=numeric(0),vk=numeric(0),
iden=character(0)),
validity=valid8ion
);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
length8ion <- function(x)
#TITLE returns the length of a 'ion' object
#DESCRIPTION (ba)
# provides the length of a \code{/ion/}.
#DETAILS
#KEYWORDS misc
#PKEYWORDS
#INPUTS
#{x}<<the 'ion' object to be measured.>>
#[INPUTS]
#VALUE
# The number of items in 'x'
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# length(rbsb.ion0);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_28
#REVISED 09_04_28
#--------------------------------------------
{
# returning
length(x@nn);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8ion <- function(x,how="n")
#TITLE prints a 'ion' object
#DESCRIPTION (ba)
# print associated to a \code{/ion/} object.
#DETAILS
#KEYWORDS print
#PKEYWORDS
#INPUTS
#{x}<<the 'ion' object to be printed.>>
#[INPUTS]
#{how} << the way to make the printing:
# 'n' for node names
# 'v' for variable names
# 'i' for node numbers
# 'j' for nested variable numbers
# 'k' for variable numbers
# 'a' for everything.>>
#VALUE
# Nothing but a printing is issued
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.ion0);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_28
#REVISED 09_04_28
#--------------------------------------------
{
# some checks
che <- valid8ion(x);
if (!identical(che,TRUE)) {
erreur(che,"This /ion/ is not valid");
}
#
if (expr3present("a",how)) { how<-"nvijk";}
if (length(x)==0) { return(invisible());}
# constituting the necessary matrix
nr <- character(0); ma <- matrix(0,0,length(x@nn));
if (expr3present("n",how)) {
nr <- c(nr,"nn");
ma <- rbind(ma,x@nn);
}
if (expr3present("v",how)) { if (length(x@vn)>0) {
nr <- c(nr,"vn");
ma <- rbind(ma,x@vn);
}}
if (expr3present("i",how)) {
nr <- c(nr,"nk");
ma <- rbind(ma,x@nk);
}
if (expr3present("j",how)) {
nr <- c(nr,"k.j");
ma <- rbind(ma,x@ij);
}
if (expr3present("k",how)) { if (length(x@vk)>0) {
nr <- c(nr,"vk");
ma <- rbind(ma,x@vk);
}}
dimnames(ma) <- list(nr,x@nvn);
print(ma);
# returning
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
setMethod("print",signature(x = "ion"), print8ion);
setMethod("length",signature(x = "ion"), length8ion);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv2ion <- function(x,nom,kwhat="n",check=TRUE)
#TITLE returns the /ion/ of a series of
# nodes/variables
#DESCRIPTION (ba)
# This is a central, basic and very general function for
# programming with /rebastaba/, so not
# that easy to grasp. It is suggested to read the detail section.\cr
# From a series of nodes (or variables) indicated with 'x'
# returns their complete name/index descriptions under a 'ion' object.
# Checking can be desactivated, anyway it is of course conditional
# to \code{rbsb.mck}...\cr
# Be aware that the proposed order is not respected, nodes/variables are
# sorted!
#DETAILS
# There are different ways to designate a subset of nodes/variables belonging
# to a /nom/ object. Let A[a], A[b], A[c], B, C[1], C[2] be the set of
# variables of /nom/ \code{uu} given in the example section. Intuitively, we
# coud designate the first node in different ways: (1) as the first node,
# (2) as the node of name 'A', (3) as the first three variables of \code{uu},
# (4) as the subset of variables 'A[a]', 'A[b]' and 'A[c]'... \code{nv2ion}
# using one of these ways (and more) returns equivalent ways of defining them.\cr
# Said in a different manner, it gives the simultaneous translation
# of one way in every known ways. This could be quite useful for exchanges
# between user and algorithms. Another properties is to give the subsets
# in a unique way.\cr
# In fact \code{"-"} is \code{rbsb.all}.
#KEYWORDS misc
#PKEYWORDS node variable
#INPUTS
#{x} << indicates one or several subsets of nodes/variables of the second
# argument (\code{nom}). When they are several subsets, \code{nv2ion}
# deals with the union of them. The indication can
# be made (1) by names (\code{character}
# interpreted of nodes or variates according to the third argument \code{kwhat};
# (ii) a numeric matrix of two rows giving its columns the [node number, variable number];
# (iii) a numeric giving the index of nodes or variables according
# to the third argument \code{kwhat}.\cr
# See the description section for more insights.\cr
# Additional facilities are given by the extensions of '-'
# (when \code{x} is a character), 0 and -1 (when \code{x} is numeric).
# \code{"-"}, \code{matrix(c(0,-1),2)} and \code{0} are equivalent.
# Notice that \code{matrix(c(0,0),2)} will keep on the developped set of
# variable names (not using '-').
# >>
#{nom} <<nom object of reference.>>
#[INPUTS]
#{kwhat} << This argument is used in two different ways
# according its values. When 'x' is a single
# numeric it indicates if the user wants to specify
# a node ("n"/"N") or a variable ("v"). But when it is
# a node (either numeric or character), it indicates
# if the node is wanted ("n") of the set of variables
# of this node ("N").
#{check} <<( when TRUE checking of the argument consistence
# is performed if rbsb.mck is also TRUE.>>
#VALUE
# A 'ion' object comprising names, indices and identifications.\cr
#{@nn} <<The node names.>>
#{@vn} <<The variable names.>>
#{@nvn}<<The node[variable] names.>>
#{@ij} <<The variable indices within each node.>>
#{@nk} <<The indices at the node level.>>
#{@vk} <<The indices at the variable level.>>
#{@iden} <<The identification of the \code{x} inputs by
# a character vector of the same length and containing
# either 'nn' (-> node as node), or 'nv' (-> node as variable set),
# or 'v' (-> variable level).>>
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv2ion(1,rbsb.nom2,"n");
# nv2ion(1,rbsb.nom2,"N");
# nv2ion(1,rbsb.nom2,"v");
# nv2ion(0,rbsb.nom2,"n");
# nv2ion("-",rbsb.nom2,"n");
# nv2ion("A",rbsb.nom2,"n");
# nv2ion("B",rbsb.nom2,"n");
# nv2ion("C",rbsb.nom3,"n");
#REFERENCE
#SEE ALSO Before using \code{nv2ion}, it is suggested to run the script \code{rsba.demo.ion.r}.
#CALLING
# uniqueness is attempted but redundancy is not avoided...
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_06_28
#REVISED 10_06_10
#--------------------------------------------
{
#=====================================================
# STEP 1: investigation of the arguments, checking, preparation
#=====================================================
# some checking and preparation
if (check) {
if (rbsb.mck) {check4valid(valid8nom(nom));}
if (!(kwhat %in% c("n","N","v"))) {
erreur(kwhat,"what must be 'n', 'N' or 'v'");
}
}
#
# determining the case and the length of input
if (is.character(x)) {
if (isvide(x)) { x <- character(0); }
ca <- "cha"; na <- length(x);
} else {
if (!is.numeric(x)) {
erreur(x,"'x' must be numeric (or character)!");
} else {
if (is.matrix(x)) {
if (nrow(x)!=2) {
erreur(x,"When 'x' is a matrix, TWO rows are expected!");
} else {
ca <- "mat"; na <- ncol(x);
}
} else {
ca <- "vec"; na <- length(x);
}
}
}
#
# na is the number of asked subsets
# cha is the type under which the subsets are defined
# *vec*tor, *mat*rix, *cha*racter.
#
# preparing the result as a list
iden <- character(na);
maij <- matrix(NA,2,0);
if (na==0) { return(rbsb.ion0);}
#
lll <- c(0,cumsum(sapply(nom@x,length)));
names(lll) <- NULL;
#=====================================================
# STEP 2: processing each subset in a jbd loop
#=====================================================
for (jbd in bc(na)) {
# the ij notation is used as a common standard
# that is all coding are first translated under the
# c(i,j) format of the matrix columns, 'i' being the
# node number and 'j' the variable number.
#=====================================================
# STEP 2.A: the subset is translated into c(n,v) code
#=====================================================
if (ca=="cha") {
# under character specification
xx <- x[jbd];
if (xx==rbsb.all) {
# the shortcut
xxx <- c(0,-1);
# but this can be modified at the variable level
# with the use of 'kwhat'
if (kwhat=="N") { xxx <- c(0,0);}
} else {
# standard specification
nn <- nv2nv(xx);
no <- which(nn$nod==names(nom@x));
if (length(no)==0) {
form3affiche(x);
erreur(list(nom,nn),"Not accepted as node name in 'nom'");
}
if (xx==nn$nod) {
# at the node level
xxx <- c(no,-1);
# but this can be modified at the variable level
# with the use of 'kwhat'
if (kwhat=="N") { xxx <- c(no,0);}
} else {
# at the variable level
if (no==0) {
xxx <- c(0,0);
} else {
if (nn$var==rbsb.all) {
xxx <- c(no,0);
} else {
nv <- which(nn$var==nom@x[[nn$nod]]);
if (check) { if (length(nv)==0) {
erreur(list(nom,nn),"The variable name was not found");
}}
xxx <- c(no,nv);
}
}
}
}
}
if (ca=="mat") {
# under matrix column specification
xx <- x[,jbd];
xxx <- xx;
}
if (ca=="vec") {
# under scalar specification
xx <- x[jbd];
if (kwhat=="v") {
# at the variable level
if (xx==0) {
xxx <- c(0,0);
} else {
kn <- sum(lll < xx);
if (kn == 1) {
xxx <- c(1,xx);
} else {
xxx <- c(kn,xx-lll[kn]);
}
}
} else {
# at the node level
if (kwhat=="n") {
# at the stric node level
xxx <- c(xx,-1);
} else {
xxx <- c(xx,0);
}
}
}
#=====================================================
# STEP 2.B: checking the obtained code
#=====================================================
if (xxx[1] < -1) {
erreur(x,"Non acceptable negative node number was found");
}
if (xxx[1] > length(nom@x)) {
erreur(x,"Too high node number was found");
}
if (xxx[2] < -1) {
erreur(x,"Non acceptable negative variable number was found");
}
if (xxx[1]>0) { if (xxx[2] > length(nom@x[[xxx[1]]])) {
erreur(x,"Too high variable number was found");
}}
#=====================================================
# STEP 2.C: performing the identification
#=====================================================
if (xxx[2]==-1) { iden[jbd] <- "nn";}
if (xxx[2]== 0) { iden[jbd] <- "nv";}
if (xxx[2] > 0) { iden[jbd] <- "v";}
if (iden[jbd]=="") {
rapport("Bad identification in 'nv2ion'");
}
#=====================================================
# STEP 2.D: expanding the different codes
#=====================================================
if (xxx[1] == 0) {
# nodes are repeated
if (xxx[2] == 0) {
# all variables
xxx <- matrix(NA,2,0);
for (ii in bf(nom@x)) {
lon <- length(nom@x[[ii]]);
xxx <- cbind(xxx,matrix(c(rep(ii,lon),bc(lon)),
nrow=2,byrow=TRUE));
}
} else {
# all nodes
if (xxx[2] == -1) {
xxx <- matrix(c(1:length(nom@x),rep(0,length(nom@x))),
2,byrow=TRUE);
} else {
rapport("nv2ion: unexpected variable specification");
}
}
} else {
# a specific node
if (xxx[2] == 0) {
xxx <- matrix(c(rep(xxx[1],length(nom@x[[xxx[1]]])),
1:length(nom@x[[xxx[1]]])),
2,byrow=TRUE);
} else {
xxx <- matrix(xxx,2);
}
}
#=====================================================
# STEP 2.E: cumulating into the (n,v) way
#=====================================================
#
maij <- cbind(maij,xxx);
#
} # ending the loop (jbd in bc(na))
if (ncol(maij)==0) { return(rbsb.ion0);}
#=====================================================
# STEP 3: sorting and elimination from the matrix form
#=====================================================
maj <- 2*(10+max(maij[2,]));
sco <- maij[1,]*maj + maij[2,];
ord <- order(sco);
sco <- sco[ord];
qui <- c(TRUE,sco[-1]-sco[-length(sco)]>0);
maij <- maij[,ord[qui],drop=FALSE];
#=====================================================
# STEP 4: filling all the fields with the results
#=====================================================
res <- list(nn=character(0),vn=character(0),nvn=character(0),
ij=matrix(NA,2,0),
nk=numeric(0),vk=numeric(0),iden=character(0));
res$ij <- maij;
for (sd in bc(ncol(maij))) {
xxx <- res$ij[,sd];
res$nn <- c(res$nn,names(nom@x)[xxx[1]]);
res$nk <- c(res$nk,xxx[1]);
#
if (xxx[2]>0) {
res$vn <- c(res$vn,nom@x[[xxx[1]]][xxx[2]]);
res$vk <- c(res$vk,lll[xxx[1]]+xxx[2]);
} else {
res$vn <- c(res$vn,rbsb.all);
res$vk <- c(res$vk,0);
}
#
res$nvn <- paste(res$nn,
rbsb.cpt["variables","opening"],
res$vn,
rbsb.cpt["variables","closing"],
sep="");
}
# adaptation for unamed variables
res$nvn[res$vn==""] <- res$nn[res$vn==""];
#
# dealing with the special case of no nodes
if (length(res$nn) == 0) {
res$vn <- res$nvn <- character(0);
res$ij <- matrix(0,2,0);
res$nk <- res$vk <- numeric(0);
}
#
# returning
new("ion",nn=res$nn,vn=res$vn,nvn=res$nvn,
nk=res$nk,ij=res$ij[2,],vk=res$vk,
iden=iden);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
sort8ion <- function(ion,nom,sort="n",rm.redun=TRUE)
#TITLE sorts a 'ion' object
#DESCRIPTION (ba) sorts a 'ion' object possibly eliminating
# the redundancies
#DETAILS
# The algorithm does note take care of \code{rbsb.who}, changing
# it implies changing this algorithm...
#KEYWORDS misc
#PKEYWORDS
#INPUTS
#{ion}<<The 'ion' to be sorted.>>
#{nom}<<associated 'nom' structure to perform the sorting.>>
#[INPUTS]
#{sort} << the way to make the sorting
# 'n': according to 'nom'
# 'a'; according to the alphabet.>>
#{rm.redun} << Must the redundancies be removed?>>
#VALUE
# The sorted [reduced] 'ion'
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# uu <- rbsb.nom2;
# vv <- nv2ion(0,uu);
# print(sort8ion(vv,uu));
# print(sort8ion(vv,uu,"a"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_29
#REVISED 09_04_29
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4valid(valid8ion(ion));
}
# sorting
if (sort=="a") {
# alphabetical sorting
oo <- order(ion@nvn);
} else {
# natural sorting
oo <- order((nbnv(nom)+1)*ion@nk+ion@vk);
}
for (ii in slotNames(ion)) { if (length(slot(ion,ii))>0) {
ax <- slot(ion,ii);
slot(ion,ii) <- ax[oo];
}}
# eliminating the redundancies at the simple level
if (rm.redun) { if (length(ion)>1) {
dd <- length(ion);
rr <- c(ion@nvn[-1]!=ion@nvn[-dd],TRUE);
if (sum(rr)<length(rr)) {
for (ii in slotNames(ion)) {
slot(ion,ii) <- slot(ion,ii)[rr];
}
}
}}
# eliminating the redundancies at the global level
rr <- numeric(0);
## finding all global nodes (forgetting rbsb.who)
glo <- which("-"==ion@vn);
## finding all nodes
ano <- unique(ion@nn);
## exploring them
for (no in ano) {
## for each component of it
cno <- which(no==ion@nn);
if (length(cno) > 1) {
## are there global nodes for it
gno <- intersect(glo,cno);
if (length(gno)>0) {
## only one is sufficient
rr <- c(rr,setdiff(cno,gno[1]));
}
}
}
## removing the redundant ones
if (length(rr)>0) {
kk <- setdiff(1:length(ion),rr);
for (ii in slotNames(ion)) {
slot(ion,ii) <- slot(ion,ii)[kk];
}
}
# returning
ion;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv2nv <- function(xx)
#TITLE transforms node[variable] characters
# into node and variable characters.
#DESCRIPTION (ba)
# just removing possible square brackets to give
# back the node names ($nod) and the variable
# names ($var)
#DETAILS
# In fact square brackets are the parentheses
# given by the constant \code{rbsb.cpt["variables",]}.
#KEYWORDS misc
#INPUTS
#{xx} <<The character to transform>>
#[INPUTS]
#VALUE
# a list with two components\cr
#{$nod} <<The node names.>>
#{$var} <<The variable names: '' when absent.>>
#{$vva} <<The variable names but node name when absent.>>
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv2nv(c("A","A[666]","")); # list(nod=c("A","A"),var=c("","666",""),vva=c("A","666","")
#REFERENCE
#FUTURE
#SEE ALSO
#CALLING
#COMMENT
#AUTHOR J.-B. Denis
#CREATED 09_04_23
#REVISED 10_08_12
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4tyle(xx,"character",-1);
}
#
res <- list(nod=character(0),var=character(0),vvar=character(0));
cou1 <- rbsb.cpt["variables","opening"];
cou2 <- rbsb.cpt["variables","closing"];
#
for (jbd in bf(xx)) {
x <- xx[jbd];
if (x == "") {
res$nod <- c(res$nod,"");
res$var <- c(res$var,"");
res$vva <- c(res$vva,"");
} else {
uu <- strsplit(x,cou1,fixed=TRUE);
res$nod <- c(res$nod,uu[[1]][1]);
if (x==uu[[1]][1]) {
res$var <- c(res$var,"");
} else {
vv <- strsplit(uu[[1]][2],cou2,fixed=TRUE);
if (uu[[1]][2]==vv[[1]][1]) {
erreur(x,"Missing bracketing");
} else {
res$var <- c(res$var,vv[[1]][1]);
}
}
#
if (res$var[jbd]=="") { res$vva <- c(res$vva,res$nod[jbd]);
} else { res$vva <- c(res$vva,res$var[jbd]);}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
isempty <- function(x)
#TITLE tests the nullness of objects
#DESCRIPTION
# Returns TRUE is the structure is empty.\cr
# This trick was proposed because the \code{NULL} cannot replace
# any kind of objects. Generally, constant finishing with \code{0} like
# \code{rbsb.lis0}, \code{rbsb.dfr0}... are null objects.\cr
# Notice that \code{isempty("")} is FALSE.
#DETAILS
# see the code to know the list.
#PKEYWORDS
#KEYWORDS programming
#INPUTS
#{x} <<object to be scrutinazed>>
#[INPUTS]
#VALUE
# TRUE when the object is considered as empty
# FALSE if not
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# isempty(numeric(0));
# isempty(NULL);
# isempty(rbsb.fau0);
# isempty("");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_15
#REVISED 10_09_23
#--------------------------------------------
{
if (is.null(x)) { return(TRUE);}
if (length(x)==0) { return(TRUE);}
if (identical(x,rbsb.log0)) { return(TRUE);}
if (identical(x,rbsb.num0)) { return(TRUE);}
if (identical(x,rbsb.cha0)) { return(TRUE);}
if (identical(x,rbsb.lis0)) { return(TRUE);}
if (identical(x,rbsb.fun0)) { return(TRUE);}
if (identical(x,rbsb.dfr0)) { return(TRUE);}
FALSE;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
isvide <- function(x)
#TITLE to avoid difficulty with is.null
#DESCRIPTION (ba)
# returns TRUE is the structure is null,
# empty or vide. For this last case, their list is given
# by \code{rbsb.null} which is increased with new objects by the children
# packages.\cr
# Any object being null for \code{isempty} is for \code{isvide}. \cr
# Notice that \code{isvide("")} is FALSE.
#DETAILS
# Have a look to the code itself.
#PKEYWORDS
#KEYWORDS utilities
#PKEYWORDS utilities
#INPUTS
#{x} <<object to be scrutinazed>>
#[INPUTS]
#VALUE
# TRUE when the object is considered as
# not filled, FALSE if not.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# isvide(NULL);
# isvide(rbsb.fau1);
# isvide(rbsb.fau0);
# isvide("");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_15
#REVISED 10_09_27
#--------------------------------------------
{
# initializing
res <- FALSE;
# covering 'isempty' null cases
if (isempty(x)) { return(TRUE);}
# covering some special non null cases
if (is.function(x)) { return(FALSE);}
if (is.data.frame(x)) { return(FALSE);}
# looping over the null declared objects
for (oo in rbsb.null) {
tutu <- paste("if (identical(x,",oo,")) {res <- TRUE;}",sep="");
eval(parse(text=tutu));
}
# looking for non significant character
if (is.character(x)) { if (length(x)==1) { if (x=="") { return(TRUE);}}}
# at last null was not dectected
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
ustat <- function(wh="all")
#TITLE provides function computing usual statistics.
#DESCRIPTION
# This function is aimed to be an argument for the function
# \code{msdistri}. It returns a list of two parallel components:
# (1) a vector a names of each statistics and
# (2) a list of functions computing the statistics.
#DETAILS
# The statistics are computed after removing the \code{NA}
# values.\cr
# See the code for more details.
#KEYWORDS
#PKEYWORDS plot
#INPUTS
#[INPUTS]
#{wh} <<Defines which statistics must be used.
# The different possibilities are:\cr
# "all" for all of the following;\cr "n" for number of
# non missing values;\cr "m" for the mean;\cr "s" for the
# standard deviation;\cr "M" for the median;\cr "i" for the minimum;\cr
# "a" for the maximum;\cr "2" for the 0.025 and 0.975
# quantiles and their difference;\cr
# "5" for the 0.05 and 0.95 quantiles and
# their difference;\cr "i" for the
# 0.25 and 0.75 quantiles and their difference.>>
#VALUE
# A named list, each component being a function taking
# a vector of numeric values as input and returning
# the corresponding statistics.
#EXAMPLE
# rbsb3k("RESET"); # For R checking compliance
# print(ustat("n"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_09_20
#REVISED 10_09_20
#--------------------------------------------
{
#
# checking
if (rbsb.mck) {
check4tyle(wh,rbsb.chara,1);
}
#
# interpreting the order
if (wh=="all") { wh <- "nmsMia25i";}
#
# preparing the result
res <- vector("list",0);
#
# creating the necessary functions
if (expr3present("n",wh)) {
res$nb <- function(x) {
sum(!is.na(x));
}
res$'%nb' <- function(x) {
round(sum(!is.na(x)) * 100 / length(x),0)
}
}
#
if (expr3present("m",wh)) {
res$mean <- function(x) {
mean(x,na.rm=TRUE);
}
}
#
if (expr3present("s",wh)) {
res$std.dev. <- function(x) {
sqrt(var(x,na.rm=TRUE));
}
}
#
if (expr3present("M",wh)) {
res$median <- function(x) {
median(x,na.rm=TRUE);
}
}
#
if (expr3present("i",wh)) {
res$minimum <- function(x) {
min(x,na.rm=TRUE);
}
}
#
if (expr3present("a",wh)) {
res$maximum <- function(x) {
max(x,na.rm=TRUE);
}
}
#
if (expr3present("2",wh)) {
res$'Q2.5%' <- function(x) {
quantile(x,0.025,na.rm=TRUE);
}
res$'Q97.5%' <- function(x) {
quantile(x,0.975,na.rm=TRUE);
}
res$'R95%' <- function(x) {
quantile(x,0.975,na.rm=TRUE) -
quantile(x,0.025,na.rm=TRUE);
}
}
#
if (expr3present("5",wh)) {
res$'Q5%' <- function(x) {
quantile(x,0.05,na.rm=TRUE);
}
res$'Q95%' <- function(x) {
quantile(x,0.95,na.rm=TRUE);
}
res$'R90%' <- function(x) {
quantile(x,0.95,na.rm=TRUE) -
quantile(x,0.05,na.rm=TRUE);
}
}
#
if (expr3present("i",wh)) {
res$'Q25%' <- function(x) {
quantile(x,0.25,na.rm=TRUE);
}
res$'Q75%' <- function(x) {
quantile(x,0.75,na.rm=TRUE);
}
res$'R50%' <- function(x) {
quantile(x,0.75,na.rm=TRUE) -
quantile(x,0.25,na.rm=TRUE);
}
}
#
#
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
look4k <- function(words,where=rbsb.pko,what="dv",
strict=TRUE,how=length(words),imp=TRUE)
#TITLE looks associated constants to some words
#DESCRIPTION
# Looks among the constants defined in the different
# packages which seems relevant with respect to some
# proposed keywords.
#DETAILS
# The investigation is a fuzzy search with \code{agrep}
# values.\cr
#KEYWORDS
#PKEYWORDS search
#INPUTS
#{words} <<vector of keywords to be investigated.>>
#[INPUTS]
#{where} <<names of the packages to be investigated.>>
#{what} <<what must be returned? \code{d} for definition
# and \code{v} for value.>>
#{strict} <<Must the search be an exact (versus fuzzy) search?>>
#{how} <<how many positive results (with respect to each keyword
# must be displayed?>>
#{imp} <<must the result be displayed?
# if not a list with the result is returned.>>
#VALUE
# Nothing but the result is displayed.
#EXAMPLE
# rbsb3k("RESET"); # For R checking compliance
# look4k("print");
# look4k("daf",what="");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_10_11
#REVISED 10_10_11
#--------------------------------------------
{
#
# to avoid R remards
chaine <- val <- tout <- rbsb.cha0;
#
# checking
if (rbsb.mck) {
check4tyle(words,rbsb.chara,c(1,Inf));
check4tyle(where,rbsb.chara,c(1,Inf));
check4tyle(strict,rbsb.logic,1);
check4tyle(how,rbsb.numer,1,c(1,length(words)));
}
#
# preparing the result
re2 <- vector("list",0);
res <- numeric(0);
if (strict) { madi <- 0;
} else { madi <- 0.1;}
#
# investigating series of constants
for (kk in bf(where)) {
toto <- paste("chaine <- ",where[kk],"3k('definitions');",sep="");
eval(parse(text=toto));
nako <- paste(where[kk],names(chaine),sep=".");
rr <- rep(0,length(nako));
names(rr) <- nako;
# for a given series of constants, investigating each constant
for (ko in bf(rr)) {
cha <- paste(names(rr)[ko],chaine[ko],sep=" ");
# applying to the proposed series of keywords
for (ww in words) {
toto <- paste("tout <- agrep(ww,cha,max.distance=madi,ignore.case=TRUE);");
eval(parse(text=toto));
if (length(tout)>0) { rr[ko] <- rr[ko] + 1;}
}
}
# adding the discovery to the result
res <- c(res,rr);
#
# extracting the positive constants
for (ii in bf(rr)) { if (rr[ii] >= how) {
uuu <- names(rr)[ii];
toto <- paste("val <- ",uuu,";",sep="");
eval(parse(text=toto));
re2[[uuu]] <- list(definition = chaine[ii],value=val);
}}
}
#
# printing
if (imp) {
for (ii in bf(re2)) {
form3title(names(re2)[ii],laft=0);
if (expr3present("d",what)) {
form3paragraphe(re2[[ii]]$definition);
}
if (expr3present("v",what)) {
print(re2[[ii]]$value);
}
}
return(invisible());
}
#
# returning the values
re2;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Try the rbsb package in your browser
Any scripts or data that you put into this service are public.
rbsb documentation built on May 2, 2019, 4:41 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
###########################################
###########################################
########
#((((((( NEW S4 CLASS des
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8des <- function(object)
#TITLE checks a /des/
#DESCRIPTION
# This function checks a /des/ objects
#DETAILS
# It is the validity method for /des/ objects.
#KEYWORDS classes
#INPUTS
#{object} <<The des object to be validated.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_08_31
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="des") {
erreur(NULL,paste("This object is not of class 'des' but '",class(object),"'",sep=""));
}
res <- character(0);
if(length(object@name)!=1) {res <- c(res,"des@name must be a character of length one");}
if(length(object@orig)>=2) {res <- c(res,"des@orig must not be a vector");}
if(length(object@time)>=2) {res <- c(res,"des@time must not be a vector");}
if(length(object@defi)>=2) {res <- c(res,"des@defi must not be a vector");}
if(length(object@role)>=2) {res <- c(res,"des@role must not be a vector");}
if (length(res)== 0) { res <- TRUE;
} else { erreur(res,w=rbsb.mwa);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
# description
setClass("des", representation(
name="character", # name of the object being described
orig="character", # scalar giving the origin
time="character", # scalar giving the time of creation/modification
defi="character", # scalar giving the definition
role="character", # scalar giving the role of the structure
comm="character" # free vector, a component = a paragraph
),
prototype=list(
name="rbsb",
orig=paste("Created by rbsb"),
time="unknown",
defi="undefined",
role=character(0),
comm=character(0)),
validity=valid8des
);
#
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8des <- function(x,...,what="ndr",empha=1)
#TITLE prints a des object
#DESCRIPTION
# This function prints in a /des/ object.
#DETAILS
# Global constant \code{rbsb.mwi} is used to justify the paragraphes.
# It is the specific print for /des/ objects.
#KEYWORDS classes
#INPUTS
#{x} <<The \code{des} object to print.>>
#[INPUTS]
#{\dots} <<Further arguments to be passed to the print function.>>
#{what} <<the fields to print:
# \code{a}=all fields,
# \code{n}=name,
# \code{d}=definition,
# \code{o}=origin,
# \code{t}=time,
# \code{r}=role,
# \code{c}=comments.>>
#{empha} <<Emphasize level of printing;
# between 0 and 10>>
#VALUE
# nothing but a print is performed
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
# Add a beginnnig way (giving only the first characters of
# each slot for not too large reports.
#AUTHOR J.-B. Denis
#CREATED 08_08_21
#REVISED 10_09_15
#--------------------------------------------
{
# some checking
che <- valid8des(x);
if (!identical(che,TRUE)) {
erreur(che,"/des/ is not valid");
}
empha <- round(max(0,min(10,empha)));
nemph <- empha -2;
what <- tolower(what);
if (expr3present("a",what)) { what <- "ndortc";}
# preparing the titles
tt <- c("Name","Definition","Origin","Time","Role","Comment(s)");
# preparing the constant according to the emphasis
if (empha == 0) {
sep=0; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- " ";
}
if (empha == 1) {
sep=0; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- " ";
}
if (empha == 2) {
sep=0; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- " ";
}
if (empha == 3) {
sep=0; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- "-";
}
if (empha == 4) {
sep=1; ed <- form3repeat(" ",2*nemph);
nbs <- 5; sou <- "==";
}
if (empha == 5) {
sep=1; ed <- form3repeat(" ",2*nemph);
nbs <- 20; sou <- "==";
}
if (empha == 6) {
sep=2; ed <- form3repeat(" ",2*nemph);
nbs <- 2; sou <- form3repeat(" ",50,FALSE,TRUE);
}
if (empha >= 7) {
sep=2; ed <- form3repeat(" ",2*nemph);
nbs <- 3; sou <- form3repeat("=",50,FALSE,TRUE);
}
#
# printing
if (expr3present("n",what)) {
if (!isempty(x@name)) {
if (x@name != "") {
form3titre(c(tt[1],x@name),nemph);
}}}
if (expr3present("d",what)) {
if (!isempty(x@defi)) {
if (x@defi != "") {
if (!isempty(x@name)) {
tt[2] <- paste("<",tt[2]," of '",x@name,"':>",sep="");
}
form3paragraphe(c(tt[2],x@defi),nemph,
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
if (expr3present("o",what)) {
if (!isempty(x@orig)) {
if (x@orig != "") {
form3paragraphe(c(tt[3],x@orig),nemph,
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
if (expr3present("t",what)) {
if (!isempty(x@time)) {
if (x@time != "") {
form3paragraphe(c(tt[4],x@time),nemph,
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
if (expr3present("r",what)) {
if (!isempty(x@role)) {
if (x@role != "") {
form3paragraphe(c(tt[5],x@role),nemph,
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
if (expr3present("c",what)) {
if (!isempty(x@comm)) {
if ((x@comm[1] != "")|(length(x@comm)>1)) {
form3paragraphe(c(tt[6],x@comm),max(0,nemph),
wid=rbsb.mwi,sep=sep,ed=ed);
}}}
form3repeat(sou,nbs,TRUE);
# returning
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#
#
setMethod("print",signature(x = "des"), print8des);
###########################################
###########################################
########
#((((((( NEW S4 CLASS faux
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8faux <- function(object)
#TITLE checks a /faux/
#DESCRIPTION
# This function checks a /faux/ objects
#DETAILS
# It is the validity method for /faux/ objects.
#KEYWORDS error
#INPUTS
#{object} <<The faux object to validate.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_08_31
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="faux") {
erreur(NULL,paste("This object is not of class 'faux' but '",class(object),"'",sep=""));
}
if ((object@level != 0) & (object@level != 1) & (object@level != 2)) {
re1 <- "faux@level must be 0, 1 or 2";
} else { re1 <- TRUE;}
re2 <- valid8des(as(object,"des"));
#
res <- character(0);
if (!identical(re1,TRUE)) { res <- c(res,re1);}
if (!identical(re2,TRUE)) { res <- c(res,re2);}
if (identical(res,character(0))) { res <- TRUE;}
#
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
################################################################################
setClass("faux",
representation(level="numeric"), # level of the error
prototype(level=0),
contains="des", # extension of a description
validity=valid8faux
);
################################################################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8faux <- function(x,...,what=2)
#TITLE prints a faux object
#DESCRIPTION
# This function prints in a interpreted way a /faux/ object.
#DETAILS
# Global constant \code{rbsb.mwi} is used to justify the paragraphes.
# It is the specific print for /faux/ objects.
#KEYWORDS error
#INPUTS
#{x} <<The faux object to be printed.>>
#[INPUTS]
#{\dots} <<Further arguments to be passed to the print function.>>
#{what} <<the level of printing
# 0= only the definition,
# 1= the origin and the definition
# 2= everything.
#VALUE
# nothing but a print is performed
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.fau1,what=2);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_01_21
#REVISED 09_09_29
#--------------------------------------------
{
#
# printing
#
what <- "ndo";
if (what==0) { what <- "d";}
if (what==2) { what <- "a";}
#
form3titre(paste("/faux/ with a level of",x@level));
print(as(x,"des"),what=what);
# returning
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
setMethod("print",signature(x = "faux"),print8faux);
###########################################
###########################################
########
#((((((( NEW S4 CLASS daf
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8daf <- function(object)
#TITLE checks a /daf/
#DESCRIPTION
# This function checks /daf/ objects
#DETAILS
# It is the validity method for /daf/ objects.
#KEYWORDS classes
#INPUTS
#{object} <<The daf object to be validated.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_01
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="daf") {
erreur(NULL,paste("This object is not of class 'daf' but '",class(object),"'",sep=""));
}
res <- character(0);
# checking the 'what' parameter
if (!(object@what %in% c("t","d","f","c","c2"))) {
res <- c(res,paste(object@what,"'what' must be 't', 'd' or 'f'"));
}
# checking the other fields
# to avoid error whe R is checking the package
if (!is.null(rbsb.snp)) { # to prevent R checking harassment
rres <- NULL; # to prevent R checking harassment
if ((object@what=="t") |
(object@what=="c") |
(object@what=="c2")) {
if (file.access(object@valu)<0) {
res <- c(res,paste(object@valu,"No file of this name seems accessible."));
}
}
if (object@what=="d") {
if(!exists(object@valu)) {
res <- c(res,paste(object@valu,"No data.frame under this name: should be a data.frame"));
}
coda <- paste("rres <- class(",object@valu,")");
eval(parse(text=coda));
if (rres!="data.frame") {
res <- c(res,paste(list(object@valu,res),"A data.frame was expected under this variable"));
}
}
if (object@what=="f") {
if(!exists(object@valu)) {
res <- c(res,paste(object@valu,"No object under this name: should be a function"));
}
coda <- paste("rres <- class(",object@valu,")");
eval(parse(text=coda));
if (rres!="function") {
res <- c(res,paste(list(object@valu,res),"A function was expected under this variable"));
}
}
} # to prevent R checking harassment
#
if (length(res)== 0) { res <- TRUE;
} else { erreur(res,w=rbsb.mwa);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
setClass("daf", representation(
des="des", # description of the data frame
what="character", # indication about the way the data.frame is
# available. 3 currently ways:
# 't' through a text file to be read
# 'd' through a data.frame itself
# 'f' through a function to be called without argument
valu="character" # the complete path of the text file when what=='t'
# the data.frame name when what=='d'
# the function name when what=='f'
),
prototype(des=new("des",name="rbsb",
orig=paste("Created by rebastaba"),
time=date(),
defi="prototype",
role=character(0),
comm=character(0)),
what="d",
valu="rbsb.dfr0"),
validity=valid8daf
);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8daf <- function(x,what="nr",whi=1:10)
#TITLE prints a daf object
#DESCRIPTION
# This function prints a /daf/ object.
#DETAILS
# It is the specific print function for /daf/ objects.
#KEYWORDS print
#PKEYWORDS daf
#INPUTS
#{x} <<The daf object.>>
#[INPUTS]
#{what} << which part of the description to print
# (see \code{print8des}).>>
#{whi} << which rows to print?\cr
# when -1: none is printed,\cr
# when 0: all are printed,\cr
# when a vector: indicates the numbers of rows to print
# (default = the first ten),\cr
# when a value: the percentage to be printed
# (50 = half of the rows)
# >>
#VALUE
# returns nothing but a printing is performed
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.daf2);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_23
#REVISED 10_02_11
#--------------------------------------------
{
# some checks
if (rbsb.mck) {
che <- valid8daf(x);
if (!identical(che,TRUE)) {
erreur(che,"/daf/ is not valid");
}
check4tyle(what,rbsb.chara,1,message="'what' must be character(1)");
}
#
nsou <- 39;
# dealing with the daf.null case
if (identical(x,rbsb.daf0)) {
form3repeat("-",nsou,TRUE);
cat("<<< daf.null >>>\n");
form3repeat("-",nsou,TRUE);
return(invisible());
}
# loading the data.frame
values <- get8daf(x);
# looking for the rows to print
if (min(whi) < 0) {
quelles <- numeric(0);
} else {
nlig <- nrow(values);
if ((identical(whi,0))|(nlig==0)) {
quelles <- bc(nlig);
} else {
if (length(whi) == 1) {
nli <- min(100,whi);
quelles <- seq(1,nlig,length=max(1,round(nlig*nli/100)));
quelles <- round(quelles);
} else {
quelles <- intersect(whi,bc(nlig));
if (length(quelles) <= 0) { quelles <- 1:min(10,nlig);}
}
}
}
# printing the description
form3repeat("-",nsou,TRUE);
print(x@des,what);
#printing the values
form3repeat("-",nsou,TRUE);
if (length(quelles)>0) {
print(values[quelles,]);
}
# returning
form3repeat("-",nsou,TRUE);
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
setMethod("print",signature(x = "daf"), print8daf);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
daf2list <- function(daf,simple=TRUE)
#TITLE transforms a /daf/ into a list
#DESCRIPTION
# This function transforms a /daf/ object
# into a standard list. The shortened way is used
# when \code{simple}.
#DETAILS
# By simple or shortened, it is meant that the list
# is given with a simple level of a \code{character(3)}
# (most frequent use).
#KEYWORDS misc
#PKEYWORDS daf
#INPUTS
#{daf} <<The daf object to be transformed.>>
#[INPUTS]
#{simple} <<indicates the way the list must be created.>>
#VALUE
# the resulting list
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# daf2list(rbsb.daf1);
# daf2list(NULL);
# daf2list(rbsb.daf1,FALSE);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_06_21
#REVISED 10_06_28
#--------------------------------------------
{
# degenerate case
if (isempty(daf)) { return(rbsb.lis0);}
# some checks
if (rbsb.mck) {
che <- valid8daf(daf);
if (!identical(che,TRUE)) {
erreur(che,"/daf/ is not valid");
}
}
#
if (simple) {
res <- list(daf=c(daf@des@name,daf@what,daf@valu));
} else {
res <- des2list(daf@des);
res$what <- daf@what;
res$valu <- daf@valu;
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
list2daf <- function(li)
#TITLE transforms a list into a /daf/
#DESCRIPTION
# This function transforms a list comprising
# the necessary components into a /daf/ object.
# The components of the list must be either the
# direct transcription of the slot hierarchy of /daf/
# or (shortened way) a component named \code{daf} comprising a
# \code{character(3)} with \code{des@name}, \code{what} and \code{valu} slots.
#DETAILS
# The list \code{li} can comprise more components
# which are ignored. If \code{li$daf} exists, it will
# have priority over the possible slot components.
#KEYWORDS misc
#PKEYWORDS daf
#INPUTS
#{li} <<The list to be transformed into a /daf/.>>
#[INPUTS]
#VALUE
# returns the resulting /daf/ object.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# lu <- daf2list(new("daf",des=new("des",name="rbsb",
# orig=paste("Created by rebastaba"),
# time=date(),
# defi="prototype",
# role=character(0),
# comm=character(0)),
# what="d",
# valu="rbsb.dfr0"));
# list2daf(lu);
# list2daf(list(daf=c("simple","d","rbsb.dfr0")));
# list2daf(rbsb.lis0);
#REFERENCE
#SEE ALSO daf2list
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_06_22
#REVISED 10_06_28
#--------------------------------------------
{
# degenerate case
if (isempty(li)) { return(rbsb.daf0);}
if (isempty(li$daf)) {
# slot case
if (rbsb.mck) {
didi <- setdiff(slotNames("daf"),names(li));
if (length(didi) > 1) {
erreur(names(li),"The components of this list does not allow to create a /daf/ through the slot case");
}
}
#
res <- new("daf",des=list2des(li$des),
what=li$what,
valu=li$valu);
} else {
# simple case
if (rbsb.mck) {
check4tyle(li$daf,rbsb.chara,3,message="A character(3) was expected: name, what, valu");
}
res <- new("daf",des=char2des(li$daf[1]),
what=li$daf[2],
valu=li$daf[3]);
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
list2des <- function(li)
#TITLE transforms a consistent list into a /des/ object
#DESCRIPTION
# Just analyzing the components of the list
# (consistent names have to be used) which are supposed
# to be character and tackle them to produce consistent
# slots of a /des/ object.
# The components of the list must be either the
# direct transcription of the slots of /des/
# or a component named \code{des} comprising a
# \code{character(1:Inf)} with des@name, des@orig, des@time,
# des@defi,des@role,des@comm in this order.
#DETAILS
#PKEYWORDS des
#KEYWORDS classes
#INPUTS
#{li} <<The list to be transformed into a des object.>>
#[INPUTS]
#VALUE
# The generated 'des' object
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(list2des(list(name="A",role="Just to see",comm="Not very interesting")));
# print(list2des(list(des=c("A","","","","Just to see","Not very interesting"))));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_01_06
#REVISED 10_06_28
#--------------------------------------------
{
if (isempty(li)) { return(rbsb.des0);}
#
if (isempty(li$des)) {
# slot case
if (rbsb.mck) {
if (isempty(li$name)) {
erreur(names(li),"The components of this list does not allow to create a /des/ through the slot case: at least $name is compulsory");
}
}
#
if (is.null(li$orig)) { li$orig <- rbsb.cha0;}
if (is.null(li$time)) { li$time <- rbsb.cha0;}
if (is.null(li$defi)) { li$defi <- rbsb.cha0;}
if (is.null(li$role)) { li$role <- rbsb.cha0;}
if (is.null(li$comm)) { li$comm <- rbsb.cha0;}
if (is.null(li$name)) {
erreur(li,"the component 'name' is compulsory");
}
#
res <- new("des",name=li$name,orig=li$orig,time=li$time,
defi=li$defi,role=li$role,comm=li$comm);
} else {
# simple case
if (rbsb.mck) {
check4tyle(li$des,rbsb.chara,c(1,Inf),message="A character(1:Inf) was expected: name,... orig, time, defi, role, comm.");
}
name <- li$des[1];
nbl <- length(li$des);
if (nbl > 1) { orig <- li$des[2];} else { orig <- rbsb.cha0;}
if (nbl > 2) { time <- li$des[3];} else { time <- rbsb.cha0;}
if (nbl > 3) { defi <- li$des[4];} else { defi <- rbsb.cha0;}
if (nbl > 4) { role <- li$des[5];} else { role <- rbsb.cha0;}
if (nbl > 5) { comm <- li$des[-(1:5)];} else { comm <- rbsb.cha0;}
res <- new("des",name=name,time=time,defi=defi,
role=role,comm=comm);
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
des2list <- function(des,simple=FALSE)
#TITLE transforms a /des/ object into a list.
#DESCRIPTION
# Transforms a /des/ object into a list.
# More or less the reverse of \code{list2des}.
# When \code{simple} the shortened way is used.
#DETAILS
# Simple way means that the description is given
# as a character vector, not as a list. See the
# proposed examples.
#PKEYWORDS des
#KEYWORDS classes
#INPUTS
#{des} <<The /des/ to be transformed into a list.>>
#[INPUTS]
#{simple} <<indicates the way the list must be created.>>
#VALUE
# The generated list
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# des2list(rbsb.des1);
# des2list(rbsb.des1,TRUE);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_03_08
#REVISED 10_06_28
#--------------------------------------------
{
# checking
if (!valid8des(des)) {
str(des);
erreur(NULL,"This /des/ is not valid!");
}
# filling
if (simple) {
res <- list(des=des@name);
if (!isempty(des@orig)) {
res$des <- c(res$des,des@orig);
if (!isempty(des@time)) {
res$des <- c(res$des,des@time);
if (!isempty(des@defi)) {
res$des <- c(res$des,des@defi);
if (!isempty(des@role)) {
res$des <- c(res$des,des@role);
if (!isempty(des@comm)) {
res$des <- c(res$des,des@comm);
}
}
}
}
}
} else {
res <- vector("list",0);
if (!isempty(des@name)) { res$name <- des@name;}
if (!isempty(des@orig)) { res$orig <- des@orig;}
if (!isempty(des@time)) { res$time <- des@time;}
if (!isempty(des@defi)) { res$defi <- des@defi;}
if (!isempty(des@role)) { res$role <- des@role;}
if (!isempty(des@comm)) { res$comm <- des@comm;}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
char2des <- function(x)
#TITLE transforms, if necessary, a single character into a /des/ object
#DESCRIPTION
# when x is not a \code{character(1)} or a /des/ an error is issued
#DETAILS
#PKEYWORDS des
#KEYWORDS utilities
#INPUTS
#{x} <<name for the /des/ to be created, or an already existing /des/.>>
#[INPUTS]
#VALUE
# a /des/ object (not modfyied when x was already a /des/.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(char2des("toto"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_03_03
#REVISED 09_09_29
#--------------------------------------------
{
# checking
if ((!is.character(x)) &
(length(x)!=1) &
(!is(x,"des"))) {
erreur(x,"Must be 'character(1)' or a 'des' object!");
}
# returning
if (is(x,"des")) { res <- x;
} else {
res <- new("des",name=x,
orig=paste("created by",rbsb.msi),
time=now("d"));
}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
get8daf <- function(daf,wh=0,strict=FALSE,check=TRUE)
#TITLE returns the data frame associated to a /daf/
#DESCRIPTION
# Returns the data frame associated to a /daf/.
# The row numbers can be choosen with \code{wh}.
#DETAILS
# According to \code{daf@what} a different action is performed to
# get the data frame:
#{f} << The named \code{daf@valu} function is used without argument.>>
#{d} << The named \code{daf@valu} data frame is used.>>
#{t} << The named \code{daf@valu} file is read with read.table.>>
#{c} << The named \code{daf@valu} file is read with read.csv.>>
#{c2} << The named \code{daf@valu} file is read with read.csv2.>>
# For \code{t}, \code{c} or \code{c2} cases, \code{header=TRUE}
# and \code{comment.char='#'}.
#KEYWORDS datasets
#INPUTS
#{daf} <<The /daf/ to be read.>>
#[INPUTS]
#{wh} << numeric giving the numbers of the observations
# to be read. Zero means all observations.>>
#{strict} << When TRUE a fatal error is issued
# if some asked observations does not exist. If
# not the present ones are returned.>>
#{check} << Must the /daf/ object be checked?>>
#VALUE
# a data frame
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_05_11
#REVISED 10_03_08
#--------------------------------------------
{
# checking
if (check) {if (rbsb.mck) {valid8daf(daf);}}
if (rbsb.mck) {
check4tyle(wh,"integer",-1,message="These are supposed to be the asked row numbers");
if (min(wh) < 0) { erreur(wh,"Negative row number were asked.");}
}
# getting the values
if (daf@what == "t") {
res <- read.table(daf@valu,header=TRUE,comment.char="#");
}
#
if (daf@what == "c") {
res <- read.csv(daf@valu,header=TRUE,comment.char="#");
}
#
if (daf@what == "c2") {
res <- read.csv2(daf@valu,header=TRUE,comment.char="#");
}
#
if (daf@what == "d") {
coda <- paste("res <-",daf@valu);
eval(parse(text=coda));
}
#
if (daf@what == "f") {
coda <- paste("res <-" ,daf@valu,"()");
eval(parse(text=coda));
}
# possible observations
opo <- bc(nrow(res));
# defining and checking the asked observations
if (identical(wh,0)) { wh <- opo;}
prendre <- intersect(wh,opo);
if (strict) {
if (length(prendre) < length(wh)) {
erreur(list(opo,wh),"Some asked observations were not found");
}
}
# selecting the values
res <- res[prendre,,drop=FALSE];
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
char2vma <- function(cha,what=rbsb.vma["v"],
xsep=rbsb.sep1,nat="C")
#TITLE transforms a character into a vector (or matrix, or array)
#DESCRIPTION
# from a \code{character} vector, returns a vector, or a matrix, or
# an array of characters with possibly names, or dimames. The information
# can be supplied in different ways for each of the three possibilities.
# It is advised to try the proposed examples.
#DETAILS
# The processing is done in character mode but the result can be
# transformed into numerical or logical values with the help of argument \code{nat}.
# \cr
# In fact \code{rbsb.vma} coding is used for the argument \code{what}.
# This allows to easily modify the coding.
#PKEYWORDS
#KEYWORDS IO
#INPUTS
#{cha} << The character to transform.>>
#[INPUTS]
#{what} << Indicates which structure to return: either
# a vector, a matrix or an array.
# \cr \cr
# For vectors, the possibilities are c/C/u/v/U/V :
# \cr\code{rbsb.vma["c"]} for a no named character(1); collapsing
# is done with \code{rbsb.sep0}.
# \cr\code{rbsb.vma["C"]} for a no named character() of any length
# (components are separated with \code{xsep} whiwh are
# removed from the result); collapsing
# is done with \code{rbsb.sep0}.
# \cr\code{rbsb.vma["v"]} or \code{rbsb.vma["u"]} for a no named vector;
# \cr\code{rbsb.vma["V"]} for a named vector with
# all names before the values; then an even number
# of components must be provided.
# \cr\code{rbsb.vma["U"]} for a named vector with
# names interlaced with the value (name_i, value_i); then an even number
# of components must be provided.
# \cr \cr
# For matrices, the possibilities are m/n/o/p/M/N/O/P:
# \cr\code{rbsb.vma["m"]} for a no named matrix given by row, two adjacent rows
# being separated with \code{xsep} sequence, introduced as one of the
# component of \code{cha}, then for a 2x3 matrix, the length of \code{cha}
# will be 6+2 = 8.
# \cr\code{rbsb.vma["n"]} for a matrix with only the columns names. The expected sequence is
# the names of columns, then the values as for \code{rbsb.vma["m"]}; then for a 2x3
# matrix, the length of \code{cha} will be 3+1+8=12.
# \cr\code{rbsb.vma["o"]} for a matrix with only rows named. The expected sequence is
# name of row, values of rows... Then 2x3 will imply a length of 8+2=10.
# \cr\code{rbsb.vma["p"]} when names for columns and rows, in a mixed way... Then 2x3 will imply
# a length of 14.
# \cr
# When \code{rbsb.vma["M"],rbsb.vma["N"],rbsb.vma["O"],rbsb.vma["P"]},
# the same but the matrix will be transposed after
# being read; said in another way, the values are given by columns.
# \cr \cr
# For arrays, the possibilities are a/A/b/B:
# \cr\code{rbsb.vma["a"]} for a no named array, the dimensions, \code{xsep}, the values in
# the classical order (varying the first index the fastest). 2x3 will give
# a length of 2+1+6=9.
# \cr\code{rbsb.vma["A"]} for a dimnamed array, the dimensions, \code{xsep}, the dimnames of each
# dimension in the right order also separated and finished with \code{xsep}.
# 2x3 will gives a length of 2+1+2+1+3+1+6=16.
# \cr\code{rbsb.vma["b"]} for a named dimensions array, the dimensions, \code{xsep}, the names for the
# dimension in the right order not separated and finished with \code{xsep}.
# 2x3 will gives a length of 2+1+2+1+6=12.
# \cr\code{rbsb.vma["B"]} for a named and dimnamed array, the dimensions, \code{xsep}, the names for the
# dimension in the right order not separated and finished with \code{xsep}, then the dimnames separated
# before the values.
# 2x3 will gives a length of (2+1)+(2+1)+(2+1+3+1)+(6)=19.
# >>
#{xsep} << Character sequence used to separate the character vector into blocks
# giving information about the structure (see the examples).>>
#{nat} << Nature of the returned structure. Can be \code{C} for character, \code{N}
# for numeric or \code{L} for logical.>>
#VALUE a vector or a matrix or an array according to the inputs
#EXAMPLE
# rbsb3k("reset"); # For R checking convenience
## vectors
# char2vma(letters,"c");
# char2vma(letters,"C",xsep="e");
# char2vma(letters);
# char2vma(letters,"V");
# char2vma(letters,"u");
# char2vma(c(LETTERS,letters),rbsb.vma["V"]);
# char2vma(c("A","a","B","b","C","c"),rbsb.vma["U"]);
## matrices
# char2vma(c(1:3,"//",4:6),rbsb.vma["m"]);
# char2vma(c(1:3,"//",4:6),rbsb.vma["M"]);
# char2vma(c(LETTERS[1:3],"//",1:3,"//",4:6),rbsb.vma["n"]);
# char2vma(c(LETTERS[1:3],"//",1:3,"//",4:6),"N");
# char2vma(c("a",1:3,"//","b",4:6),"o");
# char2vma(c(c(LETTERS[1:3],"//","a",1:3,"//","b",4:6)),rbsb.vma["p"]);
## arrays
# char2vma(c(2:4,"//",1:24),"a");
# char2vma(c(2:4,"//","one","two","//",LETTERS[1:3],"//",
# letters[1:4],"//",1:24),"A");
# char2vma(c(2:4,"//","one","two","//",LETTERS[1:3],"//",
# letters[1:4],"//",1:24),"A",nat="N");
#REFERENCE
#SEE ALSO \code{vma2char}
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_03_28
#REVISED 10_08_13
#--------------------------------------------
{
# flexibility
if (isempty(cha)) { cha <- rbsb.cha0;}
# of use
ssep <- which(cha==xsep);
# checking
if (rbsb.mck) {
check4tyle(cha,rbsb.chara,-1,message="cha must be a character");
#
check4tyle(what,rbsb.chara,1,
message="what (character(1)) must indicate the type of desired output");
if (!(what %in% rbsb.vma)) {
erreur(what,"'what' not in the list of possible values...");
}
#
check4tyle(xsep,rbsb.chara,1,message="must indicate the character string of separation");
#
if (what %in% rbsb.vma[c("V","U")]) {
if ((length(cha) %% 2) != 0) {
erreur(list(cha,what),"Here the length of 'cha' must be even");
}
}
#
if (what %in% rbsb.vma[c("n","N","m","M","o","O")]) {
if (length(ssep) >= 1) {
nbc <- ssep[1] - 1;
nbr <- (length(cha)+1) / (nbc+1);
if ((nbr!=round(nbr)) | (length(cha) != (nbc*nbr+nbr-1))) {
erreur(list(what,length(cha),nbc,nbr),"Dimensions not consistent");
}
}
}
#
if (what %in% rbsb.vma[c("p","P")]) {
if (length(ssep) >= 1) {
nbc <- ssep[1] + 1;
X <- 2 + length(cha);
if ((X %% nbc) != 0) {
erreur(list(what,length(cha),nbc),"Dimensions not consistent");
}
}
}
#
if (what %in% rbsb.vma[c("a","A","b","B")]) {
# an array must be returned
if (length(ssep)==0) {
erreur(list(cha,xsep),"For arrays, dims must be provided");
}
didi <- cha[1:(ssep[1]-1)];
didi <- as.numeric(didi);
if (sum(is.na(didi))>0) {
erreur(list(cha,xsep),"Dimensions are not numeric !");
}
if (any(didi<0)) {
erreur(didi,"Negative dimensions were provided");
}
if (any(didi!=round(didi))) {
erreur(didi,"Non integer dimensions were provided");
}
X <- length(didi) + 1 + prod(didi);
if (what %in% rbsb.vma[c("A","B")]) { X <- X + sum(didi) + length(didi); }
if (what %in% rbsb.vma[c("b","B")]) { X <- X + length(didi) + 1; }
if (length(cha) != X) {
erreur(list(cha,what,xsep),"Inconsistency for an array");
}
}
#
check4tyle(nat,rbsb.chara,1,message="'nat' must be a character(1)");
}
#
res <- rbsb.cha0;
#
if (what %in% rbsb.vma["c"]) {
# a single character must be returned
# rbsb.sep0 is used as collapsor
res <- paste(cha,collapse=rbsb.sep0);
}
#
if (what %in% rbsb.vma["C"]) {
# a character must be returned
# rbsb.sep0 is used as separator
res <- paste(cha,collapse=rbsb.sep0);
res <- strsplit(res,xsep,fixed=TRUE)[[1]];
if (length(res)>1) { for (ii in 2:length(res)) {
res[ii ] <- form3decadre(res[ii ],rbsb.sep0,"",1);
res[ii-1] <- form3decadre(res[ii-1],"",rbsb.sep0,1);
}}
}
#
if (what %in% rbsb.vma[c("v","V","u","U")]) {
# a vector must be returned
if (what %in% c(rbsb.vma[c("v","u")])) {
res <- cha;
} else {
nb <- floor(length(cha)/2);
if (what == rbsb.vma["V"]) { nam <- rep(c(TRUE,FALSE),each=nb);
} else { nam <- rep(c(TRUE,FALSE),nb); }
res <- cha[!nam];
names(res) <- cha[nam];
}
}
#
if (what %in% rbsb.vma[c("m","M","n","N","o","O","p","P")]) {
# a matrix must be returned
nbc <- ssep[1] - 1;
cha <- c(cha,xsep);
if (what %in% c(rbsb.vma[c("p","P")])) {
cha <- c(" ",cha);
}
if (what %in% rbsb.vma[c("p","P")]) { add <- 1;
} else { add <- 0; }
cha <- matrix(cha,ncol=nbc+1+add,byrow=TRUE);
cha <- cha[,-ncol(cha),drop=FALSE];
if (what %in% rbsb.vma[c("m","M")]) {
res <- cha;
}
if (what %in% rbsb.vma[c("n","N")]) {
res <- cha[-1,,drop=FALSE];
dimnames(res) <- list(NULL,cha[1,,drop=FALSE]);
}
if (what %in% rbsb.vma[c("o","O")]) {
res <- cha[,-1,drop=FALSE];
dimnames(res) <- list(cha[,1,drop=FALSE],NULL);
}
if (what %in% rbsb.vma[c("p","P")]) {
res <- cha[-1,-1,drop=FALSE];
dimnames(res) <- list(cha[-1,1,drop=FALSE],cha[1,-1,drop=FALSE]);
}
if (what %in% rbsb.vma[c("M","N","O","P")]) {
res <- t(res);
}
}
#
if (what %in% rbsb.vma[c("a","A","b","B")]) {
if (length(ssep) == 0) { erreur(cha,"For array, dimensions must be provided");}
# an array must be returned
didi <- cha[1:(ssep[1]-1)];
didi <- as.numeric(didi);
nbdi <- length(didi);
#
if (what == rbsb.vma["a"]) { vvv <- cha[-(1:ssep[1])];}
if (what == rbsb.vma["A"]) { vvv <- cha[-(1:ssep[1+nbdi])];}
if (what == rbsb.vma["b"]) { vvv <- cha[-(1:ssep[2])];}
if (what == rbsb.vma["B"]) { vvv <- cha[-(1:ssep[2+nbdi])];}
#
res <- array(vvv,dim=didi);
#
if (what %in% rbsb.vma[c("A","B")]) {
ndi <- vector("list",0);
for (jj in bf(didi)) {
jjj <- jj + (what == rbsb.vma["B"]);
if (ssep[jjj+1]-ssep[jjj]>1) {
ndi[[jj]] <- cha[(ssep[jjj]+1):(ssep[jjj+1]-1)];
}
}
dimnames(res) <- ndi;
}
if (what %in% rbsb.vma["b"]) {
ndi <- vector("list",0);
for (jj in bf(didi)) {
ndi[[jj]] <- 1:didi[jj];
}
dimnames(res) <- ndi;
}
if (what %in% rbsb.vma[c("b","B")]) {
names(dimnames(res)) <- cha[(ssep[1]+1):(ssep[2]-1)];
}
}
# transtyping
if (nat %in% c("N","L")) {
rrr <- as.numeric(res);
if (nat == "L") { rrr <- as.logical(rrr);}
attributes(rrr) <- attributes(res);
res <- rrr;
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
vma2char <- function(x,xsep=rbsb.sep1)
#TITLE transforms a vector (or matrix, or array) into a character
#DESCRIPTION
# from a vector, or a matrix, or
# an array, returns a \code{character} vector. More or less the
# inverse function of \code{char2vma}.
#DETAILS
# When some dimnames exist, the possible missing
# ones will be added.
#PKEYWORDS
#KEYWORDS IO
#INPUTS
#{x} << The object to transform.>>
#[INPUTS]
#{xsep} << \code{character(1)} to be use for the separations.>>
#VALUE a list with two components: \code{[[1]]} the coded character vector and
# \code{[[2]]} the type according to \code{char2vma}.
#EXAMPLE
# rbsb3k("reset"); # For R checking convenience
## vectors
# vma2char(letters);
# x <- letters; names(x) <- LETTERS;
# xx <- vma2char(x);
# char2vma(xx[[1]],xx[[2]]);
# vma2char(character(0));
## matrices
# x <- matrix(1:20,4);
# vma2char(x);
# dimnames(x) <- list(letters[1:4],LETTERS[1:5]);
# vma2char(x);
# x1 <- matrix(NA,3,0);
# xx1 <- vma2char(x1);
# char2vma(xx1[[1]],xx1[[2]]);
# dimnames(x1) <- list(c("i","ii","iii"),NULL);
# xx1 <- vma2char(x1);
# char2vma(xx1[[1]],xx1[[2]]);
## arrays
# x <- array(1:24,2:4);
# vma2char(x);
# dimnames(x) <- list(1:2,c("i","ii","iii"),c("I","II","III","IV"));
# vma2char(x,xsep="|||");
# x0 <- array(NA,c(3,0,2));
# dimnames(x0) <- list(1:3,NULL,c("i","ii"));
# xx0 <- vma2char(x0);
# char2vma(xx0[[1]],xx0[[2]]);
#REFERENCE
#SEE ALSO \code{vma2char}
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_03_29
#REVISED 10_06_29
#--------------------------------------------
{
# checking
if (rbsb.mck) {
#
check4tyle(xsep,rbsb.chara,1,message="must indicate the character string of separation");
#
if (!is.vector(x) &
!is.matrix(x) &
!is.array(x)) {
erreur(class(x),"'x' must be a vector or a matrix or an array!");
}
}
#
res <- vector("list",2);
names(res) <- c("character","type");
#
if (is.array(x)&(!is.matrix(x))) {
# dealing with an array
res[[1]] <- c(as.character(dim(x)),xsep);
if (is.null(dimnames(x))) {
res[[2]] <- rbsb.vma["a"];
} else {
nna <- dimnames(x);
for (hh in bf(nna)) {
if (is.null(nna[[hh]])) {
nna[[hh]] <- bc(dim(x)[hh]);
}
}
if (is.null(names(nna))) {
for (ii in bf(nna)) {
res[[1]] <- c(res[[1]],nna[[ii]],xsep);
}
res[[2]] <- rbsb.vma["A"];
} else {
res[[1]] <- c(res[[1]],names(nna),xsep);
for (ii in bf(nna)) {
res[[1]] <- c(res[[1]],nna[[ii]],xsep);
}
res[[2]] <- rbsb.vma["B"];
}
}
res[[1]] <- c(res[[1]],as.character(x));
} else {
if (is.matrix(x)) {
# dealing with a matrix
if (is.null(dimnames(x))) {
res[[1]] <- character(0);
for (ii in bc(nrow(x))) {
res[[1]] <- c(res[[1]],x[ii,],xsep);
}
res[[1]] <- res[[1]][-length(res[[1]])];
res[[2]] <- rbsb.vma["m"];
} else {
nna <- dimnames(x);
for (hh in bf(nna)) {
if (is.null(nna[[hh]])) {
nna[[hh]] <- bc(dim(x)[hh]);
}
}
res[[1]] <- c(as.character(nna[[2]]),xsep);
for (ii in bc(nrow(x))) {
res[[1]] <- c(res[[1]],nna[[1]][ii],as.character(x[ii,]),xsep);
}
res[[1]] <- res[[1]][-length(res[[1]])];
res[[2]] <- rbsb.vma["p"];
}
} else {
# dealing with a simple vector
if (is.null(names(x))) {
res[[1]] <- as.character(x);
res[[2]] <- rbsb.vma["v"];
} else {
res[[1]] <- c(names(x),as.character(x));
res[[2]] <- rbsb.vma["V"];
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
is8rbsblist <- function(lili)
#TITLE checks whether a list is rbsb-compatible list or not
#DESCRIPTION
# A rbsb-list must satisfy the following two properties:
#{i} <<All components and sub-components being named.>>
#{ii} <<All components and sub-components being either a list
# or a character vector/matrix/array (vma components are called
# leafs of the rbsb-list).>>\cr
# Only such lists are handled by \code{list2file} and \code{file2list}
# functions.
#DETAILS
#PKEYWORDS
#KEYWORDS IO
#INPUTS
#{lili} << The list structure to be checked.>>
#[INPUTS]
#VALUE
# TRUE/FALSE according to the case.
# Also a global variable \code{rbsb.is8rbsblist} is created
# to give the result through a \code{des} object.
#EXAMPLE
# rbsb3k("reset");
# is8rbsblist(rbsb.lis1);
# is8rbsblist(list(rbsb.lis1));
# print(rbsb.is8rbsblist,what="c");
# is8rbsblist(list(rbsb.lis1,nu=NULL));
# print(rbsb.is8rbsblist,what="c");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_04_19
#REVISED 10_04_20
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4tyle(lili,"list",-1,message="lili must be a list");
}
# exploring the list
eee <- explore8list(lili);
# checking the presence on unamed components
# and the types of the list
comment <- rbsb.cha0;
for (ii in bc(nrow(eee))) {
if ((eee[ii,"name"]=="<NA>")|(eee[ii,"name"]=="")) {
comment <- c(comment,
paste("The component",eee[ii,"numbers"],
"has got no name:",
paste("'",eee[ii,"names"],"'",sep=""))
);
}
coco <- get8listcomp(lili,eee[ii,,drop=FALSE]);
if (length(coco) > 0) { coco <- coco[[1]];}
if (!(is.list(coco) |
is.numeric(coco) |
is.character(coco) |
is.matrix(coco) |
is.array(coco))) {
comment <- c(comment,
paste("The component (",eee[ii,"numbers"],
") with name: '",eee[ii,"names"],
"is not list/vector/matrix/array")
);
}
}
# preparing the result
if (isempty(comment)) {
res <- TRUE;
dede <- new("des",name="result",
orig="from is8rbsblist",
time=now(),
comm="This was a good rbsb-list.");
} else {
res <- FALSE;
dede <- new("des",name="result",
orig="from is8rbsblist",
time=now(),
comm=c("This was NOT a good rbsb-list.",
comment));
}
# producing the answer
assign("rbsb.is8rbsblist",dede,pos=".GlobalEnv");
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
###########################################
########
#((((((( NEW S4 CLASS nom
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8nom <- function(object)
#TITLE checks a /nom/
#DESCRIPTION
# This function checks /nom/ objects
#DETAILS
# It is the validity method for /nom/ objects.
#KEYWORDS classes
#INPUTS
#{object} <<The nom object to be validated.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_09_30
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="nom") {
erreur(NULL,paste("This object is not of class 'nom' but '",class(object),"'",sep=""));
}
res <- character(0);
if (!("x" %in% slotNames(object))) {
res <- c(res,"This supposed /nom/ has no slot @x!");
return(res);
}
#
# except when empty a named list is expected for @x
if (length(object@x)>0) {
if (is.null(names(object@x))) {
res <- c(res,"slot x of nom must be a NAMED list");
}
}
# no duplicatd node names
if (sum(duplicated(names(object@x)))>0) {
res <- c(res,"Node names must be unique");
}
# no empty node names
if ("" %in% names(object@x)) {
res <- c(res,"Node names must not be empty");
}
# for the variable names
for (jbd in bf(names(object@x))) {
# at least one variable
if (length(object@x[[jbd]])==0) {
res <- c(res,"A node (jbd) has got no variable name, '' must be introduced at minimum");
}
# no duplication within a node
if (sum(duplicated(object@x[[jbd]]))>0) {
res <- c(res,"Some of these variable names are duplicated");
}
# no empty node except when unique
if (("" %in% object@x[[jbd]])&(length(object@x[[jbd]])>1)) {
res <- c(res,"Variable names must not be empty except when the variable is unique");
}
}
#
if (length(res)== 0) { res <- TRUE;
} else { erreur(res,w=rbsb.mwa);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
setClass("nom", representation(
x="list" # list of variable names of each node, the component names
# are the node names when there is no variable name,
# must be "" NOT character(0) for the length giving
# giving the number of variables in any cases...
),
prototype(x=vector("list",0)),
validity=valid8nom
);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8nom <- function(x,...,what="v",type=0)
#TITLE prints the node-variable names
#DESCRIPTION
# prints the node-variable names of x (a 'nom' object)
#DETAILS
#KEYWORDS print
#PKEYWORDS print
#INPUTS
#{x} <<nom object>>
#[INPUTS]
#{\dots} <<Further arguments to be passed to the print function.>>
#{what} << what to print ('v'=node:variable names;
# 'nv'=node[variable] names;
# 'n' only node names)
#{type} << type of printing:
# (0) everything on the same line;
# (1) a node, a line.>>
#VALUE
# nothing a printing is issued
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.nom2);
# print(rbsb.nom2,what='nv');
#REFERENCE
#FUTURE
#SEE ALSO
#CALLING
#COMMENT
#AUTHOR J.-B. Denis
#CREATED 09_04_08
#REVISED 10_06_10
#--------------------------------------------
{
# some checks
if (rbsb.mck) {
#
che <- valid8nom(x);
if (!identical(che,TRUE)) {
erreur(che,"This /nom/ is not valid");
}
#
types <- 0:1;
if (!(type %in% types)) {
erreur(list(types,type),"Bad argument");
}
#
forma <- c("v","n","nv");
if (!(what %in% forma)) {
erreur(list(forma,what),"Bad argument");
}
}
#
if (nbnv(x) > 0) {
for (ii in names(x@x)) {
if (what=="n") {
cat(" ",ii);
}
if (what=="v") {
cat(" ",ii);
cat(form3liste(x@x[[ii]],none=character(0),OPA="[",CPA="]",opa="",cpa="",sep="|"));
}
if (what=="nv") {
cat(" ");
if (identical(x@x[[ii]],"")) { cat(ii);
} else {
cat(form3liste(x@x[[ii]],none=character(0),OPA="",CPA="",opa=paste(ii,"[",sep=""),cpa="]",sep=","));
}
}
if (type==1) { if (ii!=names(x@x)[nbnv(x)]) { cat("\n");}}
}
}
cat("\n");
#
# returning
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
length8nom <- function(x)
#TITLE returns the length of a 'nom' object
#DESCRIPTION
# provides the number of nodes of a \code{/nom/}.
#DETAILS
#KEYWORDS misc
#PKEYWORDS
#INPUTS
#{x}<<the 'nom' object to be measured.>>
#[INPUTS]
#VALUE
# The number of nodes in 'x'
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# length(rbsb.nom1);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_29
#REVISED 09_04_29
#--------------------------------------------
{
# returning
length(x@x);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
setMethod("print",signature(x = "nom"), print8nom);
setMethod("length",signature(x = "nom"), length8nom);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
x2nom <- function(x)
#TITLE returns the "nom" slot of an object
#DESCRIPTION
# when 'x' is a 'nom' object returns it. Else
# checks if \code{x@nom} exists and returns it, if not
# a fatal error is issued.
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{x} <<the bn/gn/dn/gn/.. or nom object>>
#[INPUTS]
#VALUE
# a 'nom' object
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# identical(rbsb.nom0,x2nom(rbsb.nom0));
#COMMENT
#AUTHOR J.-B. Denis
#CREATED 09_04_20
#REVISED 09_09_29
#--------------------------------------------
{
if (!is(x,"nom")) {
if (!("nom" %in% slotNames(x))) {
str(x);
erreur(slotNames(x),"'x' is not a 'nom' object or does not have got such a slot!");
}
x <- x@nom;
}
# returning
x;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
char2nom <- function(nova)
#TITLE transforms a character into a 'nom' object
#DESCRIPTION
# returns a \code{/nom/} whose names/variables comes from \code{nova}.
# Repetitions are possible and eliminated.
#DETAILS
# nodes and variables/nodes are sorted.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nova} <<character.>>
#[INPUTS]
#VALUE
# a 'nom' object with nodes possibly comprising covariables
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print.default(char2nom(LETTERS[1:4]));
# print(char2nom(c("C[b]","A","B[one]","C[b]","C[a]","B[two]")));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 10_07_06
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4tyle(nova,"character",-1);
}
## preparing
nova <- sort(unique(nova));
nono <- nv2nod(nova);
nova <- nv2var(nova);
## getting the x slot
no <- sort(unique(nono));
# first the node names
xx <- as.list(rep("",length(no)));
names(xx) <- no;
# second the variate names
for (nn in no) {
ou <- which(nn==nono)
vv <- nova[ou];
xx[[nn]] <- sort(vv);
}
res <- new("nom",x=xx);
if (rbsb.mck) {check4valid(valid8nom(res));}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nom2char <- function(nom,of="v",sort=FALSE)
#TITLE transforms a /nom/ into a character
#DESCRIPTION
# returns a character of the variables or node from a \code{/nom/}.
#DETAILS
# Notice that \code{char2nom(nom)} is equivalent to \code{nv2ion(0,nom,"v")@nvn}.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nom} <<The \code{nom} object to be transformed.>>
#[INPUTS]
#{of} <<'v' to return the set of variables; 'n' to return the set
# of involved nodes.>>
#{sort} <<Must the nodes and names be sorted?>>
#VALUE
# a \code{character}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nom2char(rbsb.nom3);
# nom2char(rbsb.nom3,"n");
#REFERENCE
#SEE ALSO nom2char
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_06
#REVISED 10_09_27
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
if (!(of %in% c("v","n"))) {
erreur(of,"Must be 'v' for 'variables' or 'n' for 'nodes'");
}
}
## preparing
if (of == "n") {
# node names
res <- names(nom@x);
} else {
# variable names
res <- character(0);
for (ii in bf(nom@x)) {
nn <- names(nom@x)[ii];
if(isvide(nom@x[[ii]])) {
res <- c(res,nn);
} else {
res <- c(res,paste(nn,rbsb.cpt["variables","opening"],
nom@x[[ii]],
rbsb.cpt["variables","closing"],sep=""));
}
}
}
#
if (sort) { res <- sort(res);}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
list2nom <- function(lili)
#TITLE transforms a list into a /nom/
#DESCRIPTION
# simply returns \code{nom} with its unique slot \code{@x}
# being equal to \code{lili}. This
# function was introduced for consistency with other
# objects and to prepare future evolutions
#DETAILS
# According to \code{rbsb.mck} the produced object is checked.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{lili} <<The \code{list} object to be transformed.>>
#[INPUTS]
#VALUE
# The resulting \code{nom}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# list2nom(rbsb.nom3@x);
#REFERENCE
#SEE ALSO nom2list
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_07
#REVISED 10_07_07
#--------------------------------------------
{
## preparing
res <- new("nom",x=lili);
# checking
if (rbsb.mck) {
check4valid(valid8nom(res));
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nom2list <- function(nom)
#TITLE transforms a /nom/ into a list
#DESCRIPTION
# simply returns \code{nom@x} which is a list. This
# function was introduced for consistency with other
# objects and to prepare future evolutions
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nom} <<The \code{nom} object to be transformed.>>
#[INPUTS]
#VALUE
# The resulting \code{list}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nom2list(rbsb.nom3);
#REFERENCE
#SEE ALSO list2nom
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_07
#REVISED 10_07_07
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
}
## preparing
res <- nom@x;
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
sort8nom <- function(nom,by="Aa")
#TITLE sorts a /nom/ according to various ways
#DESCRIPTION
# Nodes and variables of the \code{nom} are sorted
# according the alphabet, the number of variables.
#DETAILS
# Compatible criteria can be used simultaneously.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nom} <<The \code{nom} object to be sorted.>>
#[INPUTS]
#{by} <<A \code{character(1)} indicating the kind of sorting
# by the letters in it. \code{a} for sorting the variables
# within the node in alphabetical order. \code{A} for the nodes
# and/or \code{S} with respect to their numbers of variates.>>
#VALUE
# The resulting \code{nom}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# sort8nom(rbsb.nom3,"S");
# print(sort8nom(rbsb.nom7,"Aa"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_07
#REVISED 10_07_08
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(by,"character",1,message="'by' must be 'character(1)'");
}
## preparing
on <- bf(nom@x);
if (expr3present("S",by)) { on <- order(sapply(nom@x,length));}
if (expr3present("A",by)) { on <- order(names(nom@x));}
res <- vector("list",length(nom@x));
names(res) <- names(nom@x)[on];
al <- expr3present("a",by);
for (ii in bf(nom@x)) {
iii <- names(res)[ii];
if (!al) { res[[ii]] <- nom@x[[iii]];
} else { res[[ii]] <- sort(nom@x[[iii]]);}
}
res <- new("nom",x=res);
if (rbsb.mck) { check4valid(valid8nom(res));}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
compare8nom <- function(noma,nomb,level="v")
#TITLE compares two /nom/s
#DESCRIPTION
# compares two /nom/s either at the node or
# at the variable level.
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{noma} <<The first \code{nom} to be compared.>>
#{nomb} <<The second \code{nom} to be compared.>>
#[INPUTS]
#{level} <<'v' or 'n' to indicate if the comparaison
# must be made at the 'variable' or 'node' level.>>
#VALUE
# A list of three /nom/ named \code{$a_b}, \code{$b_a} and
# \code{$a.b} giving the respectively the set differences and the
# intersection of the choosen items.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# compare8nom(rbsb.nom2,rbsb.nom3);
# compare8nom(rbsb.nom2,rbsb.nom3,"n");
# compare8nom(rbsb.nom5,rbsb.nom3);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_08
#REVISED 10_07_08
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(noma));
check4valid(valid8nom(nomb));
check4tyle(level,"character",1,message="'level' must be 'character(1)'");
if (!(level %in% c("v","n"))) {
erreur(level,"'level' must be 'v' or 'n'");
}
}
# taking care of the level
if (level == "n") {
noma <- nom2nom(noma);
nomb <- nom2nom(nomb);
}
# making the set operations
itema <- nom2char(noma);
itemb <- nom2char(nomb);
res <- vector("list",0);
res[["a_b"]] <- char2nom(setdiff(itema,itemb));
res[["b_a"]] <- char2nom(setdiff(itemb,itema));
res[["a.b"]] <- char2nom(intersect(itema,itemb));
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nom2nom <- function(nom,what="n")
#TITLE transform a /nom/.
#DESCRIPTION
# Reduces a /nom/ to its node.
#DETAILS
# For the moment, this is the only possiblility;
# further on more ideas can occur.
#KEYWORDS misc
#PKEYWORDS nom
#INPUTS
#{nom} <<The \code{nom} object to be transformed.>>
#[INPUTS]
#{what} <<\code{character(1)} indicating the kind of
# transformation. \code{n} for removing all the
# the possible variables, leaving only the nodes.>>
#VALUE
# The resulting \code{nom}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(nom2nom(rbsb.nom7));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_07_08
#REVISED 10_07_08
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(what,"character",1,message="'by' must be 'character(1)'");
}
## preparing
if (expr3present("n",what)) {
res <- lapply(bf(nom@x),function(x){"";});
names(res) <- names(nom@x);
res <- new("nom",x=res);
}
# checking
if (rbsb.mck) { check4valid(valid8nom(res));}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv2nod <- function(vvn)
#TITLE transforms complete variable names into node names
#DESCRIPTION
# No ckeck is made about the existence of the node names
#DETAILS
# the syntax analysis is minimal, looking for a square bracket
# and eliminating evething from that point !
#KEYWORDS misc
#PKEYWORDS node
#INPUTS
#{vvn} <<vector of variable names>>
#[INPUTS]
#VALUE
# vector of deduced node names
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv2nod("aa"); # "aa" is returned
# nv2nod(c("a[e]","az[ee]","b")); # c("a","az","b") is returned
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# This function has been added to get the parents of an alk
# whithout reference to a gn/bn.
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_01_15
#REVISED 10_09_22
#--------------------------------------------
{
sep <- rbsb.cpt["variables","opening"];
un <- function(x) {x[1];}
res <- sapply(strsplit(vvn,sep,fixed=TRUE),un);
if (length(res) == 0) { res <- character(0);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv2var <- function(nvn)
#TITLE returns the variable name from a node[variable] name
#DESCRIPTION
# Just removing the node name and square brackets.
# \code{nvn} can be a vector. In case there is no variable name,
# the standard "" is returned
#DETAILS
# Variable name can be numeric and is returned as such
#KEYWORDS misc
#PKEYWORDS name var
#INPUTS
#{nvn} << character of the complete variable name>>
#[INPUTS]
#VALUE
# variable name without node name
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv2var(c("A[5]","B"));
#REFERENCE
#SEE ALSO va3va
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 08_01_03
#REVISED 10_09_22
#--------------------------------------------
{
sop <- rbsb.cpt["variables","opening"];
scl <- rbsb.cpt["variables","closing"];
#
res <- character(0);
for (i in bf(nvn)) {
nv <- nvn[i];
if (length(grep(sop,nv,fixed=TRUE)) == 0) {
# no variable name
res <- c(res,"");
} else {
if ((grep(sop,nv,fixed=TRUE) != 1) ||
(grep(scl,nv,fixed=TRUE) != 1)) {
cat("you provide (",nv,") as complete node[variable] name\n",sep="");
erreur(NULL,"BUT it does not comprise the corresponding parenthesis!");
}
nv <- strsplit(nv,sop,fixed=TRUE)[[1]][2];
nv <- strsplit(nv,scl,fixed=TRUE)[[1]][1];
res <- c(res,nv);
}
}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nbnv <- function(x,what=-1)
#TITLE number of nodes/variables for a /nom/ or an /object@nom/
#DESCRIPTION
# According to 'what', returns the number of
# nodes/variables for a \code{nom} or an object
# comprising a slot \code{@nom}.
#DETAILS
# no check is performed.
#KEYWORDS misc
#PKEYWORDS node nb gn dn nom
#INPUTS
#{x} <<the bn/gn/dn/gn or nom object>>
#[INPUTS]
#{what} <<
# -1: returns the number of nodes
# 0: returns the total number of variables
# i: returns the number of variables of the i-th node.
# (For convenience 'n' is translated as -1 and 'v' is
# translated as 0).>>
#VALUE
# The number of nodes or variables, accordingly to what
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nbnv(rbsb.nom2); # number of nodes
# nbnv(rbsb.nom2,0); # number of variates
#COMMENT
# Remember that in most cases the number of
# variables of a dn associated to a bn is one
# more due to the scoring ">?<" variable.\cr
# This function is a fusion of former nbnd and
# nbva functions.
#AUTHOR J.-B. Denis
#CREATED 07_06_13
#REVISED 09_11_25
#--------------------------------------------
{
#
# checking
if (rbsb.mck) {
check4tyle(what,c("integer","character"),1,message="Bad 'what' in 'nbnv'!");
}
x <- x2nom(x);
if (what=="n") { what <- -1;}
if (what=="v") { what <- 0;}
if (!is.numeric(what)) { erreur(what,"'what' is not acceptable!");}
if (what==-1) {
res <- length(names(x@x));
} else {
nvs <- sapply(x@x,length);
if (length(nvs)==0) {nvs <- numeric(0);}
if (what==0) {
res <- sum(nvs);
} else {
if ((what < -1)|(what > length(nvs))) {
erreur(list(x,what),"'what' is not a node number of the nom 'x'");
} else {
res <- nvs[what];
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
and4nom <- function(nom,nod,var="")
#TITLE adds one node to a /nom/
#DESCRIPTION
# returns \code{nom} after adding it a new node.
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom node
#INPUTS
#{nom} <<The /nom/ to be completed.>>
#{nod} <<Name for the new node (character(1)).>>
#[INPUTS]
#{var} <<Name(s) for the variable of the new node.>>
#VALUE
# The /nom/ completed
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.nom2);
# print(and4nom(rbsb.nom2,"D","z"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 09_05_06
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(nod,"character", 1,message="The node name (only one) was expected.");
check4tyle(var,"character",c(1,Inf),message="The variable name(s) was expected [At least one].");
if (nod %in% nanv(nom,"n")) {
erreur(list(nom,nod),"The node you proposed already exists.");
}
if (length(unique(var))!=length(var)) {
erreur(var,"You proposed duplicated variable names for the same node.");
}
}
# addition
nom@x[[nod]] <- var;
# returning
nom;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
rmnd4nom <- function(nom,nod)
#TITLE removes one node to a /nom/
#DESCRIPTION
# removes one (and only one) node to a \code{/nom/}.
#DETAILS
#KEYWORDS misc
#PKEYWORDS nom node
#INPUTS
#{nom} <<The /nom/ to be restricted.>>
#{nod} <<Name of the name to be removed (character(1)).>>
#[INPUTS]
#VALUE
# The reducede /nom/
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rmnd4nom(rbsb.nom2,"A"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 09_05_06
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(nod,"character", 1,message="The node name (only one) was expected.");
if (!(nod %in% nanv(nom,"n"))) {
erreur(list(nom,nod),"The node you proposed does not exist in that /nom/.");
}
}
# removing
qui <- which(names(nom@x)!=nod);
nom@x <- nom@x[qui];
# returning
nom;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nanv <- function(x,what=-1)
#TITLE returns the names of nodes/variables of x2nom(nom)
#DESCRIPTION
# According to 'what', returns the names of
# nodes/variables for \code{nom} or \code{nom@nom}.
#DETAILS
# As it is a very basic function, no check is
# made about the arguments.
#KEYWORDS misc
#PKEYWORDS nom node variable
#INPUTS
#{x} <<the object to consider>>
#[INPUTS]
#{what} <<
# -2: returns all names of the variables (without the node name)
# -1: returns the names of the nodes
# 0: returns all names of the variables (including the node name)
# i: returns the names of the variables of the i-th node.
# (For convenience 'n' is translated as -1 and 'v' is
# translated as 0).>>
#VALUE
# The names of nodes or variables, accordingly to \code{what}.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nanv(rbsb.nom2) # node names
# nanv(rbsb.nom2,0) # node[variable] names
# nanv(rbsb.nom2,-2) # variable names
#COMMENT
# Remember that in most cases the number of
# variables of a dn associated to a bn is one
# more due to the scoring ">?<" variable.\cr
# This function is consistent with nbnv.
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 09_11_25
#--------------------------------------------
{
# no checking
#
sep <- rbsb.cpt["variables",];
#
x <- x2nom(x);
if (what=="n") { what <- -1;}
if (what=="v") { what <- 0;}
if (!is.numeric(what)) { erreur(what,"'what' is not acceptable!");}
if (what==-1) {
res <- names(x@x);
} else {
if (what==0) {
res <- character(0);
for (ii in bf(x@x)) {
if (all(x@x[[ii]]=="")) {
res <- c(res,names(x@x)[ii]);
} else {
res <- c(res,
paste(names(x@x[ii]),
sep[1],
x@x[[ii]],
sep[2],
sep="")
);
}
}
} else {
if (what==-2) {
res <- character(0);
for (ii in bf(x@x)) {
res <- c(res,x@x[[ii]]);
}
} else {
if ((what < -1)|(what > length(x@x))) {
erreur(list(x,what),"'what' is not a node number of the nom 'x'");
} else {
ii <- what;
if (all(x@x[[ii]]=="")) {
res <- names(x@x)[ii];
} else {
res <- paste(names(x@x[ii]),
sep[1],
x@x[[ii]],
sep[2],
sep="");
}
}
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv3nom <- function(na,nom)
#TITLE detects the existence of names into x2nom(nom)
#DESCRIPTION
# Detects the existence of 'na' as a valid node names or
# a valid variable names included into \code{nom}
# or \code{nom@nom}.
#DETAILS
# In case of identical variable and node names, the node
# will be retained: \code{nv3nom("a",new("nom",x=list(a="a")))}
# returns 1, not -1.
#KEYWORDS misc
#PKEYWORDS node
#INPUTS
#{na} <<name vector to be looked for>>
#{nom} <<nom object to make the correspondence.>>
#[INPUTS]
#VALUE
# a named (with \code{na}) numeric vector of \code{length(na)}.
# Its values are:
# -i when a variable name of the ith node
# 0 when no correspondance;
# 1 when a node name with variable(s);
# 2 when a node[variable] name;
# 3 when a node name without variable.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv3nom(c("C[1]","C[10]","2","C","B","a"), rbsb.nom3);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_16
#REVISED 10_09_22
#--------------------------------------------
{
# transforming
nom <- x2nom(nom);
# some checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4tyle(na,rbsb.chara,-1);
}
# preparing
res <- rep(0,length(na));
names(res) <- na;
vari <- nanv(nom,-2);
node <- nanv(nom,-1);
nova <- nanv(nom, 0);
if (length(nom)>0) {
# looking for single variables
var <- which(apply(outer(na,vari,"=="),1,sum)==1);
res[var] <- -1;
# looking for nodes
nod <- which(apply(outer(na,node,"=="),1,sum)==1);
res[nod] <- 1;
# looking for node[variable]
nov <- which(apply(outer(na,nova,"=="),1,sum)==1);
res[nov] <- 2
# refining the nodes and variables alone
for (ii in bf(res)) {
nam <- names(res)[ii];
if (res[ii] == 1) {
if (all(nom@x[[nam]]=="")) {
# this is a single node
res[ii] <- 3;
}
}
if (res[ii] == -1) {
# a single variable looking for its node
vou <- which(nam==vari)[1];
nou <- nv2nod(nova)[vou];
res[ii] <- - which(nou==names(nom@x));
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
valid8ion <- function(object)
#TITLE checks a /ion/
#DESCRIPTION (ba)
# This function checks /ion/ objects
#DETAILS
# It is the validity method for /ion/ objects.
#KEYWORDS classes
#INPUTS
#{object} <<The ion object to be validated.>>
#[INPUTS]
#VALUE
# TRUE when the object seems acceptable
# else a character describing the error(s)
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_01
#REVISED 10_06_23
#--------------------------------------------
{
if (class(object)!="ion") {
erreur(NULL,paste("This object is not of class 'ion' but '",class(object),"'",sep=""));
}
res <- character(0);
#
# each slot must have the same lenght
nl <- length(object@nn);
if (length(object@vn) != nl) { res <- c(res,"length of @vn is different from this of @nn");}
if (length(object@nvn)!= nl) { res <- c(res,"length of @nvn is different from this of @nn");}
if (length(object@nk) != nl) { res <- c(res,"length of @nk is different from this of @nn");}
if (length(object@ij) != nl) { res <- c(res,"length of @ij is different from this of @nn");}
if (length(object@vk) != nl) { res <- c(res,"length of @vk is different from this of @nn");}
#
# all variate names must be different
if (length(object@nvn) != length(unique(object@nvn))) {
res <- c(res,paste(object@nvn,"repetitions between variate names"));
}
#
if (length(res)== 0) { res <- TRUE;
} else { erreur(res,w=rbsb.mwa);}
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
# see the comment into nv2ion for some explanation...
#
setClass("ion", representation(
nn="character", # node names
vn="character", # variable names
nvn="character", # node[variable] names
nk="numeric", # node numbers
ij="numeric", # variable numbers within node
vk="numeric", # variable numbers
iden="character" # identification of the inputs
),
prototype(nn=character(0),vn=character(0),nvn=character(0),
nk=numeric(0),ij=numeric(0),vk=numeric(0),
iden=character(0)),
validity=valid8ion
);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
length8ion <- function(x)
#TITLE returns the length of a 'ion' object
#DESCRIPTION (ba)
# provides the length of a \code{/ion/}.
#DETAILS
#KEYWORDS misc
#PKEYWORDS
#INPUTS
#{x}<<the 'ion' object to be measured.>>
#[INPUTS]
#VALUE
# The number of items in 'x'
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# length(rbsb.ion0);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_28
#REVISED 09_04_28
#--------------------------------------------
{
# returning
length(x@nn);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
print8ion <- function(x,how="n")
#TITLE prints a 'ion' object
#DESCRIPTION (ba)
# print associated to a \code{/ion/} object.
#DETAILS
#KEYWORDS print
#PKEYWORDS
#INPUTS
#{x}<<the 'ion' object to be printed.>>
#[INPUTS]
#{how} << the way to make the printing:
# 'n' for node names
# 'v' for variable names
# 'i' for node numbers
# 'j' for nested variable numbers
# 'k' for variable numbers
# 'a' for everything.>>
#VALUE
# Nothing but a printing is issued
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# print(rbsb.ion0);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_28
#REVISED 09_04_28
#--------------------------------------------
{
# some checks
che <- valid8ion(x);
if (!identical(che,TRUE)) {
erreur(che,"This /ion/ is not valid");
}
#
if (expr3present("a",how)) { how<-"nvijk";}
if (length(x)==0) { return(invisible());}
# constituting the necessary matrix
nr <- character(0); ma <- matrix(0,0,length(x@nn));
if (expr3present("n",how)) {
nr <- c(nr,"nn");
ma <- rbind(ma,x@nn);
}
if (expr3present("v",how)) { if (length(x@vn)>0) {
nr <- c(nr,"vn");
ma <- rbind(ma,x@vn);
}}
if (expr3present("i",how)) {
nr <- c(nr,"nk");
ma <- rbind(ma,x@nk);
}
if (expr3present("j",how)) {
nr <- c(nr,"k.j");
ma <- rbind(ma,x@ij);
}
if (expr3present("k",how)) { if (length(x@vk)>0) {
nr <- c(nr,"vk");
ma <- rbind(ma,x@vk);
}}
dimnames(ma) <- list(nr,x@nvn);
print(ma);
# returning
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
setMethod("print",signature(x = "ion"), print8ion);
setMethod("length",signature(x = "ion"), length8ion);
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv2ion <- function(x,nom,kwhat="n",check=TRUE)
#TITLE returns the /ion/ of a series of
# nodes/variables
#DESCRIPTION (ba)
# This is a central, basic and very general function for
# programming with /rebastaba/, so not
# that easy to grasp. It is suggested to read the detail section.\cr
# From a series of nodes (or variables) indicated with 'x'
# returns their complete name/index descriptions under a 'ion' object.
# Checking can be desactivated, anyway it is of course conditional
# to \code{rbsb.mck}...\cr
# Be aware that the proposed order is not respected, nodes/variables are
# sorted!
#DETAILS
# There are different ways to designate a subset of nodes/variables belonging
# to a /nom/ object. Let A[a], A[b], A[c], B, C[1], C[2] be the set of
# variables of /nom/ \code{uu} given in the example section. Intuitively, we
# coud designate the first node in different ways: (1) as the first node,
# (2) as the node of name 'A', (3) as the first three variables of \code{uu},
# (4) as the subset of variables 'A[a]', 'A[b]' and 'A[c]'... \code{nv2ion}
# using one of these ways (and more) returns equivalent ways of defining them.\cr
# Said in a different manner, it gives the simultaneous translation
# of one way in every known ways. This could be quite useful for exchanges
# between user and algorithms. Another properties is to give the subsets
# in a unique way.\cr
# In fact \code{"-"} is \code{rbsb.all}.
#KEYWORDS misc
#PKEYWORDS node variable
#INPUTS
#{x} << indicates one or several subsets of nodes/variables of the second
# argument (\code{nom}). When they are several subsets, \code{nv2ion}
# deals with the union of them. The indication can
# be made (1) by names (\code{character}
# interpreted of nodes or variates according to the third argument \code{kwhat};
# (ii) a numeric matrix of two rows giving its columns the [node number, variable number];
# (iii) a numeric giving the index of nodes or variables according
# to the third argument \code{kwhat}.\cr
# See the description section for more insights.\cr
# Additional facilities are given by the extensions of '-'
# (when \code{x} is a character), 0 and -1 (when \code{x} is numeric).
# \code{"-"}, \code{matrix(c(0,-1),2)} and \code{0} are equivalent.
# Notice that \code{matrix(c(0,0),2)} will keep on the developped set of
# variable names (not using '-').
# >>
#{nom} <<nom object of reference.>>
#[INPUTS]
#{kwhat} << This argument is used in two different ways
# according its values. When 'x' is a single
# numeric it indicates if the user wants to specify
# a node ("n"/"N") or a variable ("v"). But when it is
# a node (either numeric or character), it indicates
# if the node is wanted ("n") of the set of variables
# of this node ("N").
#{check} <<( when TRUE checking of the argument consistence
# is performed if rbsb.mck is also TRUE.>>
#VALUE
# A 'ion' object comprising names, indices and identifications.\cr
#{@nn} <<The node names.>>
#{@vn} <<The variable names.>>
#{@nvn}<<The node[variable] names.>>
#{@ij} <<The variable indices within each node.>>
#{@nk} <<The indices at the node level.>>
#{@vk} <<The indices at the variable level.>>
#{@iden} <<The identification of the \code{x} inputs by
# a character vector of the same length and containing
# either 'nn' (-> node as node), or 'nv' (-> node as variable set),
# or 'v' (-> variable level).>>
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv2ion(1,rbsb.nom2,"n");
# nv2ion(1,rbsb.nom2,"N");
# nv2ion(1,rbsb.nom2,"v");
# nv2ion(0,rbsb.nom2,"n");
# nv2ion("-",rbsb.nom2,"n");
# nv2ion("A",rbsb.nom2,"n");
# nv2ion("B",rbsb.nom2,"n");
# nv2ion("C",rbsb.nom3,"n");
#REFERENCE
#SEE ALSO Before using \code{nv2ion}, it is suggested to run the script \code{rsba.demo.ion.r}.
#CALLING
# uniqueness is attempted but redundancy is not avoided...
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_06_28
#REVISED 10_06_10
#--------------------------------------------
{
#=====================================================
# STEP 1: investigation of the arguments, checking, preparation
#=====================================================
# some checking and preparation
if (check) {
if (rbsb.mck) {check4valid(valid8nom(nom));}
if (!(kwhat %in% c("n","N","v"))) {
erreur(kwhat,"what must be 'n', 'N' or 'v'");
}
}
#
# determining the case and the length of input
if (is.character(x)) {
if (isvide(x)) { x <- character(0); }
ca <- "cha"; na <- length(x);
} else {
if (!is.numeric(x)) {
erreur(x,"'x' must be numeric (or character)!");
} else {
if (is.matrix(x)) {
if (nrow(x)!=2) {
erreur(x,"When 'x' is a matrix, TWO rows are expected!");
} else {
ca <- "mat"; na <- ncol(x);
}
} else {
ca <- "vec"; na <- length(x);
}
}
}
#
# na is the number of asked subsets
# cha is the type under which the subsets are defined
# *vec*tor, *mat*rix, *cha*racter.
#
# preparing the result as a list
iden <- character(na);
maij <- matrix(NA,2,0);
if (na==0) { return(rbsb.ion0);}
#
lll <- c(0,cumsum(sapply(nom@x,length)));
names(lll) <- NULL;
#=====================================================
# STEP 2: processing each subset in a jbd loop
#=====================================================
for (jbd in bc(na)) {
# the ij notation is used as a common standard
# that is all coding are first translated under the
# c(i,j) format of the matrix columns, 'i' being the
# node number and 'j' the variable number.
#=====================================================
# STEP 2.A: the subset is translated into c(n,v) code
#=====================================================
if (ca=="cha") {
# under character specification
xx <- x[jbd];
if (xx==rbsb.all) {
# the shortcut
xxx <- c(0,-1);
# but this can be modified at the variable level
# with the use of 'kwhat'
if (kwhat=="N") { xxx <- c(0,0);}
} else {
# standard specification
nn <- nv2nv(xx);
no <- which(nn$nod==names(nom@x));
if (length(no)==0) {
form3affiche(x);
erreur(list(nom,nn),"Not accepted as node name in 'nom'");
}
if (xx==nn$nod) {
# at the node level
xxx <- c(no,-1);
# but this can be modified at the variable level
# with the use of 'kwhat'
if (kwhat=="N") { xxx <- c(no,0);}
} else {
# at the variable level
if (no==0) {
xxx <- c(0,0);
} else {
if (nn$var==rbsb.all) {
xxx <- c(no,0);
} else {
nv <- which(nn$var==nom@x[[nn$nod]]);
if (check) { if (length(nv)==0) {
erreur(list(nom,nn),"The variable name was not found");
}}
xxx <- c(no,nv);
}
}
}
}
}
if (ca=="mat") {
# under matrix column specification
xx <- x[,jbd];
xxx <- xx;
}
if (ca=="vec") {
# under scalar specification
xx <- x[jbd];
if (kwhat=="v") {
# at the variable level
if (xx==0) {
xxx <- c(0,0);
} else {
kn <- sum(lll < xx);
if (kn == 1) {
xxx <- c(1,xx);
} else {
xxx <- c(kn,xx-lll[kn]);
}
}
} else {
# at the node level
if (kwhat=="n") {
# at the stric node level
xxx <- c(xx,-1);
} else {
xxx <- c(xx,0);
}
}
}
#=====================================================
# STEP 2.B: checking the obtained code
#=====================================================
if (xxx[1] < -1) {
erreur(x,"Non acceptable negative node number was found");
}
if (xxx[1] > length(nom@x)) {
erreur(x,"Too high node number was found");
}
if (xxx[2] < -1) {
erreur(x,"Non acceptable negative variable number was found");
}
if (xxx[1]>0) { if (xxx[2] > length(nom@x[[xxx[1]]])) {
erreur(x,"Too high variable number was found");
}}
#=====================================================
# STEP 2.C: performing the identification
#=====================================================
if (xxx[2]==-1) { iden[jbd] <- "nn";}
if (xxx[2]== 0) { iden[jbd] <- "nv";}
if (xxx[2] > 0) { iden[jbd] <- "v";}
if (iden[jbd]=="") {
rapport("Bad identification in 'nv2ion'");
}
#=====================================================
# STEP 2.D: expanding the different codes
#=====================================================
if (xxx[1] == 0) {
# nodes are repeated
if (xxx[2] == 0) {
# all variables
xxx <- matrix(NA,2,0);
for (ii in bf(nom@x)) {
lon <- length(nom@x[[ii]]);
xxx <- cbind(xxx,matrix(c(rep(ii,lon),bc(lon)),
nrow=2,byrow=TRUE));
}
} else {
# all nodes
if (xxx[2] == -1) {
xxx <- matrix(c(1:length(nom@x),rep(0,length(nom@x))),
2,byrow=TRUE);
} else {
rapport("nv2ion: unexpected variable specification");
}
}
} else {
# a specific node
if (xxx[2] == 0) {
xxx <- matrix(c(rep(xxx[1],length(nom@x[[xxx[1]]])),
1:length(nom@x[[xxx[1]]])),
2,byrow=TRUE);
} else {
xxx <- matrix(xxx,2);
}
}
#=====================================================
# STEP 2.E: cumulating into the (n,v) way
#=====================================================
#
maij <- cbind(maij,xxx);
#
} # ending the loop (jbd in bc(na))
if (ncol(maij)==0) { return(rbsb.ion0);}
#=====================================================
# STEP 3: sorting and elimination from the matrix form
#=====================================================
maj <- 2*(10+max(maij[2,]));
sco <- maij[1,]*maj + maij[2,];
ord <- order(sco);
sco <- sco[ord];
qui <- c(TRUE,sco[-1]-sco[-length(sco)]>0);
maij <- maij[,ord[qui],drop=FALSE];
#=====================================================
# STEP 4: filling all the fields with the results
#=====================================================
res <- list(nn=character(0),vn=character(0),nvn=character(0),
ij=matrix(NA,2,0),
nk=numeric(0),vk=numeric(0),iden=character(0));
res$ij <- maij;
for (sd in bc(ncol(maij))) {
xxx <- res$ij[,sd];
res$nn <- c(res$nn,names(nom@x)[xxx[1]]);
res$nk <- c(res$nk,xxx[1]);
#
if (xxx[2]>0) {
res$vn <- c(res$vn,nom@x[[xxx[1]]][xxx[2]]);
res$vk <- c(res$vk,lll[xxx[1]]+xxx[2]);
} else {
res$vn <- c(res$vn,rbsb.all);
res$vk <- c(res$vk,0);
}
#
res$nvn <- paste(res$nn,
rbsb.cpt["variables","opening"],
res$vn,
rbsb.cpt["variables","closing"],
sep="");
}
# adaptation for unamed variables
res$nvn[res$vn==""] <- res$nn[res$vn==""];
#
# dealing with the special case of no nodes
if (length(res$nn) == 0) {
res$vn <- res$nvn <- character(0);
res$ij <- matrix(0,2,0);
res$nk <- res$vk <- numeric(0);
}
#
# returning
new("ion",nn=res$nn,vn=res$vn,nvn=res$nvn,
nk=res$nk,ij=res$ij[2,],vk=res$vk,
iden=iden);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
sort8ion <- function(ion,nom,sort="n",rm.redun=TRUE)
#TITLE sorts a 'ion' object
#DESCRIPTION (ba) sorts a 'ion' object possibly eliminating
# the redundancies
#DETAILS
# The algorithm does note take care of \code{rbsb.who}, changing
# it implies changing this algorithm...
#KEYWORDS misc
#PKEYWORDS
#INPUTS
#{ion}<<The 'ion' to be sorted.>>
#{nom}<<associated 'nom' structure to perform the sorting.>>
#[INPUTS]
#{sort} << the way to make the sorting
# 'n': according to 'nom'
# 'a'; according to the alphabet.>>
#{rm.redun} << Must the redundancies be removed?>>
#VALUE
# The sorted [reduced] 'ion'
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# uu <- rbsb.nom2;
# vv <- nv2ion(0,uu);
# print(sort8ion(vv,uu));
# print(sort8ion(vv,uu,"a"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_29
#REVISED 09_04_29
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4valid(valid8nom(nom));
check4valid(valid8ion(ion));
}
# sorting
if (sort=="a") {
# alphabetical sorting
oo <- order(ion@nvn);
} else {
# natural sorting
oo <- order((nbnv(nom)+1)*ion@nk+ion@vk);
}
for (ii in slotNames(ion)) { if (length(slot(ion,ii))>0) {
ax <- slot(ion,ii);
slot(ion,ii) <- ax[oo];
}}
# eliminating the redundancies at the simple level
if (rm.redun) { if (length(ion)>1) {
dd <- length(ion);
rr <- c(ion@nvn[-1]!=ion@nvn[-dd],TRUE);
if (sum(rr)<length(rr)) {
for (ii in slotNames(ion)) {
slot(ion,ii) <- slot(ion,ii)[rr];
}
}
}}
# eliminating the redundancies at the global level
rr <- numeric(0);
## finding all global nodes (forgetting rbsb.who)
glo <- which("-"==ion@vn);
## finding all nodes
ano <- unique(ion@nn);
## exploring them
for (no in ano) {
## for each component of it
cno <- which(no==ion@nn);
if (length(cno) > 1) {
## are there global nodes for it
gno <- intersect(glo,cno);
if (length(gno)>0) {
## only one is sufficient
rr <- c(rr,setdiff(cno,gno[1]));
}
}
}
## removing the redundant ones
if (length(rr)>0) {
kk <- setdiff(1:length(ion),rr);
for (ii in slotNames(ion)) {
slot(ion,ii) <- slot(ion,ii)[kk];
}
}
# returning
ion;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
nv2nv <- function(xx)
#TITLE transforms node[variable] characters
# into node and variable characters.
#DESCRIPTION (ba)
# just removing possible square brackets to give
# back the node names ($nod) and the variable
# names ($var)
#DETAILS
# In fact square brackets are the parentheses
# given by the constant \code{rbsb.cpt["variables",]}.
#KEYWORDS misc
#INPUTS
#{xx} <<The character to transform>>
#[INPUTS]
#VALUE
# a list with two components\cr
#{$nod} <<The node names.>>
#{$var} <<The variable names: '' when absent.>>
#{$vva} <<The variable names but node name when absent.>>
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# nv2nv(c("A","A[666]","")); # list(nod=c("A","A"),var=c("","666",""),vva=c("A","666","")
#REFERENCE
#FUTURE
#SEE ALSO
#CALLING
#COMMENT
#AUTHOR J.-B. Denis
#CREATED 09_04_23
#REVISED 10_08_12
#--------------------------------------------
{
# checking
if (rbsb.mck) {
check4tyle(xx,"character",-1);
}
#
res <- list(nod=character(0),var=character(0),vvar=character(0));
cou1 <- rbsb.cpt["variables","opening"];
cou2 <- rbsb.cpt["variables","closing"];
#
for (jbd in bf(xx)) {
x <- xx[jbd];
if (x == "") {
res$nod <- c(res$nod,"");
res$var <- c(res$var,"");
res$vva <- c(res$vva,"");
} else {
uu <- strsplit(x,cou1,fixed=TRUE);
res$nod <- c(res$nod,uu[[1]][1]);
if (x==uu[[1]][1]) {
res$var <- c(res$var,"");
} else {
vv <- strsplit(uu[[1]][2],cou2,fixed=TRUE);
if (uu[[1]][2]==vv[[1]][1]) {
erreur(x,"Missing bracketing");
} else {
res$var <- c(res$var,vv[[1]][1]);
}
}
#
if (res$var[jbd]=="") { res$vva <- c(res$vva,res$nod[jbd]);
} else { res$vva <- c(res$vva,res$var[jbd]);}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
isempty <- function(x)
#TITLE tests the nullness of objects
#DESCRIPTION
# Returns TRUE is the structure is empty.\cr
# This trick was proposed because the \code{NULL} cannot replace
# any kind of objects. Generally, constant finishing with \code{0} like
# \code{rbsb.lis0}, \code{rbsb.dfr0}... are null objects.\cr
# Notice that \code{isempty("")} is FALSE.
#DETAILS
# see the code to know the list.
#PKEYWORDS
#KEYWORDS programming
#INPUTS
#{x} <<object to be scrutinazed>>
#[INPUTS]
#VALUE
# TRUE when the object is considered as empty
# FALSE if not
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# isempty(numeric(0));
# isempty(NULL);
# isempty(rbsb.fau0);
# isempty("");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_15
#REVISED 10_09_23
#--------------------------------------------
{
if (is.null(x)) { return(TRUE);}
if (length(x)==0) { return(TRUE);}
if (identical(x,rbsb.log0)) { return(TRUE);}
if (identical(x,rbsb.num0)) { return(TRUE);}
if (identical(x,rbsb.cha0)) { return(TRUE);}
if (identical(x,rbsb.lis0)) { return(TRUE);}
if (identical(x,rbsb.fun0)) { return(TRUE);}
if (identical(x,rbsb.dfr0)) { return(TRUE);}
FALSE;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
isvide <- function(x)
#TITLE to avoid difficulty with is.null
#DESCRIPTION (ba)
# returns TRUE is the structure is null,
# empty or vide. For this last case, their list is given
# by \code{rbsb.null} which is increased with new objects by the children
# packages.\cr
# Any object being null for \code{isempty} is for \code{isvide}. \cr
# Notice that \code{isvide("")} is FALSE.
#DETAILS
# Have a look to the code itself.
#PKEYWORDS
#KEYWORDS utilities
#PKEYWORDS utilities
#INPUTS
#{x} <<object to be scrutinazed>>
#[INPUTS]
#VALUE
# TRUE when the object is considered as
# not filled, FALSE if not.
#EXAMPLE
# rbsb3k("RESET"); # needed only for R checking, to be forgotten
# isvide(NULL);
# isvide(rbsb.fau1);
# isvide(rbsb.fau0);
# isvide("");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_15
#REVISED 10_09_27
#--------------------------------------------
{
# initializing
res <- FALSE;
# covering 'isempty' null cases
if (isempty(x)) { return(TRUE);}
# covering some special non null cases
if (is.function(x)) { return(FALSE);}
if (is.data.frame(x)) { return(FALSE);}
# looping over the null declared objects
for (oo in rbsb.null) {
tutu <- paste("if (identical(x,",oo,")) {res <- TRUE;}",sep="");
eval(parse(text=tutu));
}
# looking for non significant character
if (is.character(x)) { if (length(x)==1) { if (x=="") { return(TRUE);}}}
# at last null was not dectected
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
ustat <- function(wh="all")
#TITLE provides function computing usual statistics.
#DESCRIPTION
# This function is aimed to be an argument for the function
# \code{msdistri}. It returns a list of two parallel components:
# (1) a vector a names of each statistics and
# (2) a list of functions computing the statistics.
#DETAILS
# The statistics are computed after removing the \code{NA}
# values.\cr
# See the code for more details.
#KEYWORDS
#PKEYWORDS plot
#INPUTS
#[INPUTS]
#{wh} <<Defines which statistics must be used.
# The different possibilities are:\cr
# "all" for all of the following;\cr "n" for number of
# non missing values;\cr "m" for the mean;\cr "s" for the
# standard deviation;\cr "M" for the median;\cr "i" for the minimum;\cr
# "a" for the maximum;\cr "2" for the 0.025 and 0.975
# quantiles and their difference;\cr
# "5" for the 0.05 and 0.95 quantiles and
# their difference;\cr "i" for the
# 0.25 and 0.75 quantiles and their difference.>>
#VALUE
# A named list, each component being a function taking
# a vector of numeric values as input and returning
# the corresponding statistics.
#EXAMPLE
# rbsb3k("RESET"); # For R checking compliance
# print(ustat("n"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_09_20
#REVISED 10_09_20
#--------------------------------------------
{
#
# checking
if (rbsb.mck) {
check4tyle(wh,rbsb.chara,1);
}
#
# interpreting the order
if (wh=="all") { wh <- "nmsMia25i";}
#
# preparing the result
res <- vector("list",0);
#
# creating the necessary functions
if (expr3present("n",wh)) {
res$nb <- function(x) {
sum(!is.na(x));
}
res$'%nb' <- function(x) {
round(sum(!is.na(x)) * 100 / length(x),0)
}
}
#
if (expr3present("m",wh)) {
res$mean <- function(x) {
mean(x,na.rm=TRUE);
}
}
#
if (expr3present("s",wh)) {
res$std.dev. <- function(x) {
sqrt(var(x,na.rm=TRUE));
}
}
#
if (expr3present("M",wh)) {
res$median <- function(x) {
median(x,na.rm=TRUE);
}
}
#
if (expr3present("i",wh)) {
res$minimum <- function(x) {
min(x,na.rm=TRUE);
}
}
#
if (expr3present("a",wh)) {
res$maximum <- function(x) {
max(x,na.rm=TRUE);
}
}
#
if (expr3present("2",wh)) {
res$'Q2.5%' <- function(x) {
quantile(x,0.025,na.rm=TRUE);
}
res$'Q97.5%' <- function(x) {
quantile(x,0.975,na.rm=TRUE);
}
res$'R95%' <- function(x) {
quantile(x,0.975,na.rm=TRUE) -
quantile(x,0.025,na.rm=TRUE);
}
}
#
if (expr3present("5",wh)) {
res$'Q5%' <- function(x) {
quantile(x,0.05,na.rm=TRUE);
}
res$'Q95%' <- function(x) {
quantile(x,0.95,na.rm=TRUE);
}
res$'R90%' <- function(x) {
quantile(x,0.95,na.rm=TRUE) -
quantile(x,0.05,na.rm=TRUE);
}
}
#
if (expr3present("i",wh)) {
res$'Q25%' <- function(x) {
quantile(x,0.25,na.rm=TRUE);
}
res$'Q75%' <- function(x) {
quantile(x,0.75,na.rm=TRUE);
}
res$'R50%' <- function(x) {
quantile(x,0.75,na.rm=TRUE) -
quantile(x,0.25,na.rm=TRUE);
}
}
#
#
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
look4k <- function(words,where=rbsb.pko,what="dv",
strict=TRUE,how=length(words),imp=TRUE)
#TITLE looks associated constants to some words
#DESCRIPTION
# Looks among the constants defined in the different
# packages which seems relevant with respect to some
# proposed keywords.
#DETAILS
# The investigation is a fuzzy search with \code{agrep}
# values.\cr
#KEYWORDS
#PKEYWORDS search
#INPUTS
#{words} <<vector of keywords to be investigated.>>
#[INPUTS]
#{where} <<names of the packages to be investigated.>>
#{what} <<what must be returned? \code{d} for definition
# and \code{v} for value.>>
#{strict} <<Must the search be an exact (versus fuzzy) search?>>
#{how} <<how many positive results (with respect to each keyword
# must be displayed?>>
#{imp} <<must the result be displayed?
# if not a list with the result is returned.>>
#VALUE
# Nothing but the result is displayed.
#EXAMPLE
# rbsb3k("RESET"); # For R checking compliance
# look4k("print");
# look4k("daf",what="");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_10_11
#REVISED 10_10_11
#--------------------------------------------
{
#
# to avoid R remards
chaine <- val <- tout <- rbsb.cha0;
#
# checking
if (rbsb.mck) {
check4tyle(words,rbsb.chara,c(1,Inf));
check4tyle(where,rbsb.chara,c(1,Inf));
check4tyle(strict,rbsb.logic,1);
check4tyle(how,rbsb.numer,1,c(1,length(words)));
}
#
# preparing the result
re2 <- vector("list",0);
res <- numeric(0);
if (strict) { madi <- 0;
} else { madi <- 0.1;}
#
# investigating series of constants
for (kk in bf(where)) {
toto <- paste("chaine <- ",where[kk],"3k('definitions');",sep="");
eval(parse(text=toto));
nako <- paste(where[kk],names(chaine),sep=".");
rr <- rep(0,length(nako));
names(rr) <- nako;
# for a given series of constants, investigating each constant
for (ko in bf(rr)) {
cha <- paste(names(rr)[ko],chaine[ko],sep=" ");
# applying to the proposed series of keywords
for (ww in words) {
toto <- paste("tout <- agrep(ww,cha,max.distance=madi,ignore.case=TRUE);");
eval(parse(text=toto));
if (length(tout)>0) { rr[ko] <- rr[ko] + 1;}
}
}
# adding the discovery to the result
res <- c(res,rr);
#
# extracting the positive constants
for (ii in bf(rr)) { if (rr[ii] >= how) {
uuu <- names(rr)[ii];
toto <- paste("val <- ",uuu,";",sep="");
eval(parse(text=toto));
re2[[uuu]] <- list(definition = chaine[ii],value=val);
}}
}
#
# printing
if (imp) {
for (ii in bf(re2)) {
form3title(names(re2)[ii],laft=0);
if (expr3present("d",what)) {
form3paragraphe(re2[[ii]]$definition);
}
if (expr3present("v",what)) {
print(re2[[ii]]$value);
}
}
return(invisible());
}
#
# returning the values
re2;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Try the rbsb package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.