R/f1.rbsb2.code.r

Defines functions look4k ustat isvide isempty nv2nv sort8ion nv2ion print8ion length8ion valid8ion nv3nom nanv rmnd4nom and4nom nbnv nv2var nv2nod nom2nom compare8nom sort8nom nom2list list2nom nom2char char2nom x2nom length8nom print8nom valid8nom is8rbsblist vma2char char2vma get8daf char2des des2list list2des list2daf daf2list print8daf valid8daf print8faux valid8faux print8des valid8des

Documented in and4nom char2des char2nom char2vma compare8nom daf2list des2list get8daf is8rbsblist isempty isvide length8ion length8nom list2daf list2des list2nom look4k nanv nbnv nom2char nom2list nom2nom nv2ion nv2nod nv2nv nv2var nv3nom print8daf print8des print8faux print8ion print8nom rmnd4nom sort8ion sort8nom ustat valid8daf valid8des valid8faux valid8ion valid8nom vma2char x2nom

###########################################
###########################################
########
#((((((( 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,"[email protected] must be a character of length one");}
    if(length(object@orig)>=2) {res <- c(res,"[email protected] must not be a vector");}
    if(length(object@time)>=2) {res <- c(res,"[email protected] must not be a vector");}
    if(length(object@defi)>=2) {res <- c(res,"[email protected] must not be a vector");}
    if(length(object@role)>=2) {res <- c(res,"[email protected] 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 <- "[email protected] 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{[email protected]}, \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 [email protected], [email protected], [email protected],
# [email protected],[email protected],[email protected] 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{[email protected]} a different action is performed to 
# get the data frame:
#{f} << The named \code{[email protected]} function is used without argument.>>
#{d} << The named \code{[email protected]} data frame is used.>>
#{t} << The named \code{[email protected]} file is read with read.table.>>
#{c} << The named \code{[email protected]} file is read with read.csv.>>
#{c2} << The named \code{[email protected]} 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{[email protected]} 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([email protected]);
#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{[email protected]} 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 /[email protected]/
#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{[email protected]}.
#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{[email protected]}.
#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.