Nothing
R/f00.rbsb.code.r
In rbmn: Handling Linear Gaussian Bayesian Networks
Defines functions
r.form3repeat
r.expr3present
r.numero
r.form3names
r.form3justifie
r.check4tyle
r.erreur
r.bf
r.bd
r.bc
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.bc <- function(nb)
#TITLE sequence for a loop
#DESCRIPTION
# This function returns \code{1:nb} when \code{nb > 0} and
# \code{numeric(0)} otherwise.\cr
# Quite useful to prevent starting
# a loop of length nought
#DETAILS
#PKEYWORDS helpful
#KEYWORDS iteration
#INPUTS
#{nb} <<length of the loop>>
#[INPUTS]
#VALUE
# \code{1:nb} if \code{nb > 0}
# else \code{numeric(0)}.
#EXAMPLE
# r.bc(0);
# r.bc(5);
#REFERENCE
#SEE ALSO r.bf
#CALLING
#COMMENT
# r.bc for BouCle (loop in French)
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_18
#REVISED 09_04_05
#--------------------------------------------
{
if (is.null(nb)) {return(numeric(0));}
if (length(nb)!=1) {
r.erreur(nb,"r.bc deals only with scalar nb")
}
if (nb > 0) {return(1:max(1,round(nb)));}
numeric(0)
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.bd <- function(n1,n2)
#TITLE sequence for insertions
#DESCRIPTION
# This function returns \code{n1:n2} when \code{n1<=n2} and
# \code{numeric(0)} otherwise.\cr
# Quite useful when some insertion must be done within
# a sequence
#DETAILS
#PKEYWORDS helpful
#KEYWORDS iteration
#INPUTS
#{n1} <<first element>>
#{n2} <<second element>>
#[INPUTS]
#VALUE
# \code{n1:n2} if \code{n1<n2}
# else \code{numeric(0)}.
#EXAMPLE
# xx <- 1:5;
# for (ii in 1:6) { print(c(xx[r.bd(1,ii-1)],10,xx[r.bd(ii,5)]));}
#REFERENCE
#SEE ALSO r.bf
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 11_01_12
#REVISED 11_01_12
#--------------------------------------------
{
if (n1 <= n2) {return(n1:n2);}
numeric(0)
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.bf <- function(x)
#TITLE sequence for looping over an object
#DESCRIPTION
# This function returns \code{1:length(x)} when \code{length(x) > 0} and
# \code{numeric(0)} otherwise.
# Quite useful to prevent starting
# a loop of length nought
#DETAILS
#PKEYWORDS helpful
#KEYWORDS iteration
#INPUTS
#{x} <<vector>>
#[INPUTS]
#VALUE
# \code{1:length(x)} if \code{length(x) > 0}
# else \code{numeric(0)}.
#EXAMPLE
# r.bf(0);
# r.bf(5);
# r.bf(character(0));
# r.bf(letters);
#REFERENCE
#SEE ALSO r.bc
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 08_09_05
#REVISED 08_09_05
#--------------------------------------------
{
if (length(x) > 0) { return(1:length(x));}
numeric(0)
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.erreur <- function(x,...,w=FALSE)
#TITLE issues an error message and concludes accordingly
#DESCRIPTION
# when called this function prints x, then displays a message before stopping
# the process.
#DETAILS
#PKEYWORDS
#KEYWORDS error
#INPUTS
#{x} <<object to be printed before the message. When \code{is.null(x)}
# nothing is printed. When it is a list, all components
# of the list are successively printed.>>
#{\dots}<<pieces of message to display after pasting>>
#[INPUTS]
#{w} << Indicates if it is a simple warning>>
#VALUE
# nothing is returned
#EXAMPLE
# r.erreur(matrix(1:4,2),"This matrix is not symmetric",w=TRUE)
# r.erreur("Are you sure of it?",w=TRUE);
#
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_03
#REVISED 13_04_29
#--------------------------------------------
{
r.form3repeat("~",60,TRUE)
print(x)
message <- paste(...)
cat("<<<<< MESSAGE >>>>>\n")
print(message)
if (w) {
cat("SIMPLE WARNING:\n")
} else {
on.exit(traceback())
}
r.form3repeat("~",60,TRUE)
invisible()
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.check4tyle <- function(x,typ,len=-1,con=numeric(0),
message=NULL,fatal=TRUE,na.rm=FALSE)
#TITLE checks the type, the length and the content
# of some standard object
#DESCRIPTION
# checks the type, the length and the content
# of some standard object.
# If not correct, a message and a fatal error are issued.
# NA are detected and considered as wrong.
#DETAILS
# 'integer' has not got the meaning in \code{is.integer} R
# standard function. 'null' must be understood as
# resulting TRUE with function \code{is.null}.\cr
# 'Named character' is different from
# 'character': \code{rbsb.chara} can be used for this purpose.
#PKEYWORDS
#KEYWORDS error
#INPUTS
#{x} <<object to be checked.>>
#{typ} <<The list of correct types, among
# 'null', 'integer', 'numeric', 'character',
# 'logical', 'list', 'any', 'function', 'data.frame',
# 'matrix'. Also are 'nlogical', 'ninteger', 'nnumeric' and
# 'ncharacter' for named structures.
# As understood, 'any' implies that no
# check of the type is performed.>>
#[INPUTS]
#{len} <<If \code{length(len)==1}, the exact length
# to be checked, if not must be of length two for
# the possible range of \code{length(x)}. When -1,
# no check on the length is performed.\cr
# For data.frame, it is the number of columns.
# When \code{na.rm} the check is made after
# removing the NA values.>>
#{con} << If \code{length(con)>0}, some check about
# the content of \code{x} is done for some of the
# types. More precisely for (integer, numeric): all
# values must belong to the interval \code{[con[1],con[2]]}
# and for (character), the set of possible \code{character(1)}
# is described by \code{con}.>>
#{message} << Some additional message to be
# issued before stopping in case of error.>>
#{fatal} << what to do when discovering
# an inconsistency ? TRUE: this function prints the message
# and stops; FALSE: this function returns
# the message as a character.>>
#{na.rm} << Must the \code{NA} values be removed before checking?
# This is implemented only for the types integer, numeric,
# character and logical.>>
#VALUE
# a character with the message(s), when everything is OK
# returns a \code{character(0)}.
# But when \code{fatal} if not OK prints the
# message and stops.
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE improves the treatment of 'NA's
#AUTHOR J.-B. Denis
#CREATED 09_05_02
#REVISED 13_04_29
#--------------------------------------------
{
# checking the arguments and preparation
# accepted types by r.check4tyle
# ....
invisible()
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.form3justifie <- function(chaine,
nbc=8,
format=3,
tronc=TRUE,
carac=" ")
#TITLE formats a character string
#DESCRIPTION
# Formats character string(s).
# The main use of this function is to produce
# aligned columns lists while printing
# the rows not at the same time.
#DETAILS
#PKEYWORDS
#KEYWORDS print
#INPUTS
#{chaine}<<the character string to be printed, can be a vector.>>
#[INPUTS]
#{nbc} << Desired number of characters for the result; when
# \code{chain} is a vector can be a vector of the same length>>
#{format} << Indicates the type of alignment:\cr
# 0 no aligment (no supplementary character added to reach \code{nbc})\cr
# 1 to the left side\cr
# 2 centered\cr
# 3 to the right side>>
#{tronc} << If true, no more than
# \code{nbc} characters are returned and
# possibly the string is truncated. In that
# case, \code{$} is added for indicating the fact.>>
#{carac} << Character to use for enlarging the string>>
#VALUE a character string
#EXAMPLE
# r.form3justifie("vers")
# r.form3justifie("versification",5)
# r.form3justifie(letters[1:5],format=2,carac="+")
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 1999_05_25
#REVISED 10_07_22
#--------------------------------------------
{
# checking
# the null case
if (length(chaine)==0) { return(character(0));}
# preparing
nbc[nbc < 3] <- 8
if (length(nbc) < length(chaine)) {
nnbc <- rep(nbc,length(chaine))
} else {
nnbc <- nbc
}
#
itr <- "$"; # truncation indicator
rres <- cchaine <- chaine
for (rr in r.bf(rres)) {
res <- rres[rr]
nbc <- nnbc[rr]
chaine <- cchaine[rr]
# truncation
if ( (nchar(res) > nbc) & tronc ) {
if (format <= 1) {
res <- substring(chaine,1,nbc)
res <- paste(res,itr,sep="")
}
else {
if (format == 2) {
otg <- (nchar(chaine) - nbc) %/% 2
res <- substring(chaine,1+otg)
res <- substring(res,1,nbc)
res <- paste(itr,res,itr,sep="")
}
else {
res <- substring(chaine,1+nchar(chaine)-nbc,
nchar(chaine))
res <- paste(itr,res,sep="")
}
}
}
if ((nchar(res) < nbc) & (format != 0)) {
if (format == 1) {
while (nchar(res) < nbc) res <-
paste(res,"",collapse="",sep=carac)
}
else {
if (format == 2) {
raj <- (nbc - nchar(res)) %/% 2
if (raj > 0) {
for (jbd in 1:raj) res <-
paste(res,"",collapse="",sep=carac)
}
while (nchar(res) < nbc) {
res <- paste("",res,collapse="",sep=carac)
}
}
else {
while (nchar(res) < nbc) {
res <- paste("",res,collapse="",sep=carac)
}
}
}
}
rres[rr] <- res
}
# returning
rres
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.form3names <- function(nbn,nom=character(0),prefix="",
upca=TRUE,nume=14)
#TITLE provides systematic names for items
#DESCRIPTION
# Provides systematic names for a series of items according their
# number taking care of previous names.
#DETAILS (see the code)
#PKEYWORDS
#KEYWORDS utilities
#INPUTS
#{nbn} <<Number of new item names to generate>>
#[INPUTS]
#{nom} << Already present names (to avoid identical names).>>
#{prefix} << Systematic prefix of all names to generate. Must
# comprise the dot, if one wants such a separator
# between it and the specific part of the name.
# Of course can be 'underscore' or whatever else.>>
#{upca} << Indicates whether the letters constituting the new
# names must be uppercase or not.>>
#{nume} << Its absolute value gives the number of the letter to use
# when the alphabet is not sufficient. When negative, alphabet
# is not considered as a first possibility.>>
#VALUE
# vector with \code{nbn} different strings associated to new names
#EXAMPLE
# r.form3names(2);
# r.form3names(2,nume=-3);
# r.form3names(2,prefix="rbsb.");
# r.form3names(2,upca=FALSE);
# r.form3names(5,"D");
# r.form3names(5,"Y");
# r.form3names(30);
#REFERENCE
#SEE ALSO r.form3nume
#CALLING
#COMMENT
#FUTURE
# Monitor the number of digits to obtain series of "Z01", "Z02",... ,"Z79", "Z80".
#AUTHOR J.-B. Denis
#CREATED 07_10_19
#REVISED 10_02_15
#--------------------------------------------
{
# checking
#
if (upca) { Letters <- LETTERS
} else { Letters <- letters;}
#
if (is.null(nbn)) { return(character(0));}
if (nbn < 1) { return(character(0))
} else {
if (prefix != "") {
# keeping only the names having got the prefix then
# removing the prefixes from them (to be added further)
decom <- sapply(strsplit(nom,prefix),function(ll){length(ll);})
nom <- nom[decom == 2]
nom <- sapply(strsplit(nom,prefix),function(ll){ll[2];})
}
# looking for the maximum letter in noms
if ( length(nom) == 0 ) { mama <- 0
} else { mama <- max(1*outer(nom,Letters,"==") %*% matrix(1:26,ncol=1));}
if ((nbn < (27-mama)) & (nume>0)) {
# adding letters
res <- Letters[mama+(1:nbn)]
} else {
# adding numbered nodes
ajou <- 0; nu <- 1; res <- character(0)
while ( ajou < nbn ) {
nono <- paste(Letters[abs(nume)],nu,sep="")
if (all(nono != nom)) {
ajou <- ajou + 1
res <- c(res,nono)
}
nu <- nu+1
}
}
}
# adding the prefix
res <- paste(prefix,res,sep="")
# returning
res
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.numero <- function(qui,dans,strict=TRUE,repe=TRUE)
#TITLE returns the positions of identifiers
#DESCRIPTION
# Returns the positions of identifiers.
# From a reference set of
# identifiers returns the positions of some of them.
# If they don't belong to the list, an error is issued
# according to \code{strict}. If there are repetitions
# an error is issued or not according to \code{repe}.
#DETAILS
#PKEYWORDS helpful
#KEYWORDS
#INPUTS
#{qui} <<Identifiers the position of them is looked for.
# Must be a character or a numeric.>>
#{dans} <<The ordered vector of all identifiers.
# Must be a character or a numeric.>>
#[INPUTS]
#{strict} <<Must \code{qui} be a subset of \code{dans}.>>
#{repe} <<Are repeatitions allowed?>>
#VALUE
# A numeric vector of the positions. It is named with the identifiers.
# When the identifier does not belong to the list and \code{strict} is
# FALSE, NA values are returned.
#EXAMPLE
# r.numero(10:1,1:10);
# r.numero(c("Z","E","P","L","I","N"),LETTERS);
# r.numero(c("B","o","F","!"),LETTERS,strict=FALSE);
# r.numero(c("B","E","B","E"),LETTERS);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_03_09
#REVISED 10_10_12
#--------------------------------------------
{
# checking
qui <- as.character(qui)
dans <- as.character(dans)
if (strict) {
uu <- union(qui,dans)
if (length(uu)!=length(dans)) {
r.erreur(list(setdiff(uu,dans),dans),"Some identifiers does not belong to the list")
}
}
# computing
res <- as.numeric(outer(qui,dans,"==")%*%r.bf(dans))
names(res) <- qui
res[res==0] <- NA
# repetitions
if (!repe) {
rr <- res[!is.na(res)]
if (length(unique(rr)) < length(rr)) {
r.erreur(rr,"Some repetitions were found while forbidden!")
}
}
# returning
res
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.expr3present <- function(sch,ch,exact=FALSE,how="a")
#TITLE indicates inclusion of character string
#DESCRIPTION
# Checks if some string(s) belong(s) to a series of strings.
# When \code{exact} is FALSE, returns TRUE if the
# character string \code{sch} is included at least once
# into the character string \code{ch}.\cr
# \code{sch} can be a vector, in that case, the check is made for each
# of its components. According to \code{how} the returned
# value is vectorial or scalar. When \code{sch} is zero length then
# \code{TRUE} is returned but if not and \code{ch} is zero length
# then \code{FALSE} is returned.
#DETAILS
#PKEYWORDS
#KEYWORDS utilities
#INPUTS
#{sch} <<(\code{character}) the character string(s) to be found.>>
#{ch} <<(\code{character}) the character string(s) to investigate.>>
#[INPUTS]
#{exact} << When exact, one component must
# be strictly identical, if not a subtring is sufficient.>>
#{how} << Indicates what to do when \code{length(sch)>1}. The choice are
# \code{'v'}: a logical vector gives back each check independently;
# \code{'1'}: returns \code{TRUE} when at least one of the component belongs
# to the series \code{ch} and \code{'a'} when all components must comply to get TRUE.>>
#VALUE A logical vector with length of \code{sch}.
#EXAMPLE
# r.expr3present('a','non');
# r.expr3present('o',c('non','oui'));
# r.expr3present(c("o","oui"),c('non','oui'));
# r.expr3present(c("o","oui"),c('non','oui'),how="v");
# r.expr3present(c("A[SEX]","A[AGE]"),c("A[AGE]","A[SEX]"),how="a")
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 08_08_28
#REVISED 12_05_16
#--------------------------------------------
{
#
# degenerate cases
if (length(sch)==0) { return(TRUE);}
if (length( ch)==0) { return(FALSE);}
#
#
res <- logical(length(sch))
#
for (ii in r.bf(sch)) {
if (exact) {
res[ii] <- sum(sch[ii]==ch) > 0
} else {
res[ii] <- length(grep(sch[ii],ch)) > 0
}
}
# dealing with scalar cases
if (how == "1") { res <- any(res);}
if (how == "a") { res <- all(res);}
# returning
res
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.form3repeat <- function(cha="-",nb=10,imp=FALSE,cr=imp)
#TITLE prints a repeated given string
#DESCRIPTION
# Without adding breaking line characters, prints
# \code{nb} times a given string of characters
#DETAILS
#PKEYWORDS
#KEYWORDS print
#INPUTS
#[INPUTS]
#{cha} << The string to repeat>>
#{nb} << Number of repetitions>>
#{imp} << Printing when TRUE or returning (default)>>
#{cr} << Must a line feed be added?>>
#VALUE
# character string or printing according to \code{imp}
#EXAMPLE
# r.form3repeat('-+',20,TRUE)
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_24
#REVISED 08_09_25
#--------------------------------------------
{
nb <- max(0,round(nb))
res <- ""
for (jbd in r.bc(nb)) { res <- paste(res,cha,sep="");}
if (cr) { res <- paste(res,"\n",sep="");}
if(!imp) { return(res);}
cat(res)
invisible()
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Try the rbmn package in your browser
Any scripts or data that you put into this service are public.
rbmn documentation built on July 9, 2023, 6:37 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions r.form3repeat r.expr3present r.numero r.form3names r.form3justifie r.check4tyle r.erreur r.bf r.bd r.bc
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.bc <- function(nb)
#TITLE sequence for a loop
#DESCRIPTION
# This function returns \code{1:nb} when \code{nb > 0} and
# \code{numeric(0)} otherwise.\cr
# Quite useful to prevent starting
# a loop of length nought
#DETAILS
#PKEYWORDS helpful
#KEYWORDS iteration
#INPUTS
#{nb} <<length of the loop>>
#[INPUTS]
#VALUE
# \code{1:nb} if \code{nb > 0}
# else \code{numeric(0)}.
#EXAMPLE
# r.bc(0);
# r.bc(5);
#REFERENCE
#SEE ALSO r.bf
#CALLING
#COMMENT
# r.bc for BouCle (loop in French)
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_18
#REVISED 09_04_05
#--------------------------------------------
{
if (is.null(nb)) {return(numeric(0));}
if (length(nb)!=1) {
r.erreur(nb,"r.bc deals only with scalar nb")
}
if (nb > 0) {return(1:max(1,round(nb)));}
numeric(0)
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.bd <- function(n1,n2)
#TITLE sequence for insertions
#DESCRIPTION
# This function returns \code{n1:n2} when \code{n1<=n2} and
# \code{numeric(0)} otherwise.\cr
# Quite useful when some insertion must be done within
# a sequence
#DETAILS
#PKEYWORDS helpful
#KEYWORDS iteration
#INPUTS
#{n1} <<first element>>
#{n2} <<second element>>
#[INPUTS]
#VALUE
# \code{n1:n2} if \code{n1<n2}
# else \code{numeric(0)}.
#EXAMPLE
# xx <- 1:5;
# for (ii in 1:6) { print(c(xx[r.bd(1,ii-1)],10,xx[r.bd(ii,5)]));}
#REFERENCE
#SEE ALSO r.bf
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 11_01_12
#REVISED 11_01_12
#--------------------------------------------
{
if (n1 <= n2) {return(n1:n2);}
numeric(0)
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.bf <- function(x)
#TITLE sequence for looping over an object
#DESCRIPTION
# This function returns \code{1:length(x)} when \code{length(x) > 0} and
# \code{numeric(0)} otherwise.
# Quite useful to prevent starting
# a loop of length nought
#DETAILS
#PKEYWORDS helpful
#KEYWORDS iteration
#INPUTS
#{x} <<vector>>
#[INPUTS]
#VALUE
# \code{1:length(x)} if \code{length(x) > 0}
# else \code{numeric(0)}.
#EXAMPLE
# r.bf(0);
# r.bf(5);
# r.bf(character(0));
# r.bf(letters);
#REFERENCE
#SEE ALSO r.bc
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 08_09_05
#REVISED 08_09_05
#--------------------------------------------
{
if (length(x) > 0) { return(1:length(x));}
numeric(0)
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.erreur <- function(x,...,w=FALSE)
#TITLE issues an error message and concludes accordingly
#DESCRIPTION
# when called this function prints x, then displays a message before stopping
# the process.
#DETAILS
#PKEYWORDS
#KEYWORDS error
#INPUTS
#{x} <<object to be printed before the message. When \code{is.null(x)}
# nothing is printed. When it is a list, all components
# of the list are successively printed.>>
#{\dots}<<pieces of message to display after pasting>>
#[INPUTS]
#{w} << Indicates if it is a simple warning>>
#VALUE
# nothing is returned
#EXAMPLE
# r.erreur(matrix(1:4,2),"This matrix is not symmetric",w=TRUE)
# r.erreur("Are you sure of it?",w=TRUE);
#
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_03
#REVISED 13_04_29
#--------------------------------------------
{
r.form3repeat("~",60,TRUE)
print(x)
message <- paste(...)
cat("<<<<< MESSAGE >>>>>\n")
print(message)
if (w) {
cat("SIMPLE WARNING:\n")
} else {
on.exit(traceback())
}
r.form3repeat("~",60,TRUE)
invisible()
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.check4tyle <- function(x,typ,len=-1,con=numeric(0),
message=NULL,fatal=TRUE,na.rm=FALSE)
#TITLE checks the type, the length and the content
# of some standard object
#DESCRIPTION
# checks the type, the length and the content
# of some standard object.
# If not correct, a message and a fatal error are issued.
# NA are detected and considered as wrong.
#DETAILS
# 'integer' has not got the meaning in \code{is.integer} R
# standard function. 'null' must be understood as
# resulting TRUE with function \code{is.null}.\cr
# 'Named character' is different from
# 'character': \code{rbsb.chara} can be used for this purpose.
#PKEYWORDS
#KEYWORDS error
#INPUTS
#{x} <<object to be checked.>>
#{typ} <<The list of correct types, among
# 'null', 'integer', 'numeric', 'character',
# 'logical', 'list', 'any', 'function', 'data.frame',
# 'matrix'. Also are 'nlogical', 'ninteger', 'nnumeric' and
# 'ncharacter' for named structures.
# As understood, 'any' implies that no
# check of the type is performed.>>
#[INPUTS]
#{len} <<If \code{length(len)==1}, the exact length
# to be checked, if not must be of length two for
# the possible range of \code{length(x)}. When -1,
# no check on the length is performed.\cr
# For data.frame, it is the number of columns.
# When \code{na.rm} the check is made after
# removing the NA values.>>
#{con} << If \code{length(con)>0}, some check about
# the content of \code{x} is done for some of the
# types. More precisely for (integer, numeric): all
# values must belong to the interval \code{[con[1],con[2]]}
# and for (character), the set of possible \code{character(1)}
# is described by \code{con}.>>
#{message} << Some additional message to be
# issued before stopping in case of error.>>
#{fatal} << what to do when discovering
# an inconsistency ? TRUE: this function prints the message
# and stops; FALSE: this function returns
# the message as a character.>>
#{na.rm} << Must the \code{NA} values be removed before checking?
# This is implemented only for the types integer, numeric,
# character and logical.>>
#VALUE
# a character with the message(s), when everything is OK
# returns a \code{character(0)}.
# But when \code{fatal} if not OK prints the
# message and stops.
#EXAMPLE
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE improves the treatment of 'NA's
#AUTHOR J.-B. Denis
#CREATED 09_05_02
#REVISED 13_04_29
#--------------------------------------------
{
# checking the arguments and preparation
# accepted types by r.check4tyle
# ....
invisible()
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.form3justifie <- function(chaine,
nbc=8,
format=3,
tronc=TRUE,
carac=" ")
#TITLE formats a character string
#DESCRIPTION
# Formats character string(s).
# The main use of this function is to produce
# aligned columns lists while printing
# the rows not at the same time.
#DETAILS
#PKEYWORDS
#KEYWORDS print
#INPUTS
#{chaine}<<the character string to be printed, can be a vector.>>
#[INPUTS]
#{nbc} << Desired number of characters for the result; when
# \code{chain} is a vector can be a vector of the same length>>
#{format} << Indicates the type of alignment:\cr
# 0 no aligment (no supplementary character added to reach \code{nbc})\cr
# 1 to the left side\cr
# 2 centered\cr
# 3 to the right side>>
#{tronc} << If true, no more than
# \code{nbc} characters are returned and
# possibly the string is truncated. In that
# case, \code{$} is added for indicating the fact.>>
#{carac} << Character to use for enlarging the string>>
#VALUE a character string
#EXAMPLE
# r.form3justifie("vers")
# r.form3justifie("versification",5)
# r.form3justifie(letters[1:5],format=2,carac="+")
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 1999_05_25
#REVISED 10_07_22
#--------------------------------------------
{
# checking
# the null case
if (length(chaine)==0) { return(character(0));}
# preparing
nbc[nbc < 3] <- 8
if (length(nbc) < length(chaine)) {
nnbc <- rep(nbc,length(chaine))
} else {
nnbc <- nbc
}
#
itr <- "$"; # truncation indicator
rres <- cchaine <- chaine
for (rr in r.bf(rres)) {
res <- rres[rr]
nbc <- nnbc[rr]
chaine <- cchaine[rr]
# truncation
if ( (nchar(res) > nbc) & tronc ) {
if (format <= 1) {
res <- substring(chaine,1,nbc)
res <- paste(res,itr,sep="")
}
else {
if (format == 2) {
otg <- (nchar(chaine) - nbc) %/% 2
res <- substring(chaine,1+otg)
res <- substring(res,1,nbc)
res <- paste(itr,res,itr,sep="")
}
else {
res <- substring(chaine,1+nchar(chaine)-nbc,
nchar(chaine))
res <- paste(itr,res,sep="")
}
}
}
if ((nchar(res) < nbc) & (format != 0)) {
if (format == 1) {
while (nchar(res) < nbc) res <-
paste(res,"",collapse="",sep=carac)
}
else {
if (format == 2) {
raj <- (nbc - nchar(res)) %/% 2
if (raj > 0) {
for (jbd in 1:raj) res <-
paste(res,"",collapse="",sep=carac)
}
while (nchar(res) < nbc) {
res <- paste("",res,collapse="",sep=carac)
}
}
else {
while (nchar(res) < nbc) {
res <- paste("",res,collapse="",sep=carac)
}
}
}
}
rres[rr] <- res
}
# returning
rres
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.form3names <- function(nbn,nom=character(0),prefix="",
upca=TRUE,nume=14)
#TITLE provides systematic names for items
#DESCRIPTION
# Provides systematic names for a series of items according their
# number taking care of previous names.
#DETAILS (see the code)
#PKEYWORDS
#KEYWORDS utilities
#INPUTS
#{nbn} <<Number of new item names to generate>>
#[INPUTS]
#{nom} << Already present names (to avoid identical names).>>
#{prefix} << Systematic prefix of all names to generate. Must
# comprise the dot, if one wants such a separator
# between it and the specific part of the name.
# Of course can be 'underscore' or whatever else.>>
#{upca} << Indicates whether the letters constituting the new
# names must be uppercase or not.>>
#{nume} << Its absolute value gives the number of the letter to use
# when the alphabet is not sufficient. When negative, alphabet
# is not considered as a first possibility.>>
#VALUE
# vector with \code{nbn} different strings associated to new names
#EXAMPLE
# r.form3names(2);
# r.form3names(2,nume=-3);
# r.form3names(2,prefix="rbsb.");
# r.form3names(2,upca=FALSE);
# r.form3names(5,"D");
# r.form3names(5,"Y");
# r.form3names(30);
#REFERENCE
#SEE ALSO r.form3nume
#CALLING
#COMMENT
#FUTURE
# Monitor the number of digits to obtain series of "Z01", "Z02",... ,"Z79", "Z80".
#AUTHOR J.-B. Denis
#CREATED 07_10_19
#REVISED 10_02_15
#--------------------------------------------
{
# checking
#
if (upca) { Letters <- LETTERS
} else { Letters <- letters;}
#
if (is.null(nbn)) { return(character(0));}
if (nbn < 1) { return(character(0))
} else {
if (prefix != "") {
# keeping only the names having got the prefix then
# removing the prefixes from them (to be added further)
decom <- sapply(strsplit(nom,prefix),function(ll){length(ll);})
nom <- nom[decom == 2]
nom <- sapply(strsplit(nom,prefix),function(ll){ll[2];})
}
# looking for the maximum letter in noms
if ( length(nom) == 0 ) { mama <- 0
} else { mama <- max(1*outer(nom,Letters,"==") %*% matrix(1:26,ncol=1));}
if ((nbn < (27-mama)) & (nume>0)) {
# adding letters
res <- Letters[mama+(1:nbn)]
} else {
# adding numbered nodes
ajou <- 0; nu <- 1; res <- character(0)
while ( ajou < nbn ) {
nono <- paste(Letters[abs(nume)],nu,sep="")
if (all(nono != nom)) {
ajou <- ajou + 1
res <- c(res,nono)
}
nu <- nu+1
}
}
}
# adding the prefix
res <- paste(prefix,res,sep="")
# returning
res
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.numero <- function(qui,dans,strict=TRUE,repe=TRUE)
#TITLE returns the positions of identifiers
#DESCRIPTION
# Returns the positions of identifiers.
# From a reference set of
# identifiers returns the positions of some of them.
# If they don't belong to the list, an error is issued
# according to \code{strict}. If there are repetitions
# an error is issued or not according to \code{repe}.
#DETAILS
#PKEYWORDS helpful
#KEYWORDS
#INPUTS
#{qui} <<Identifiers the position of them is looked for.
# Must be a character or a numeric.>>
#{dans} <<The ordered vector of all identifiers.
# Must be a character or a numeric.>>
#[INPUTS]
#{strict} <<Must \code{qui} be a subset of \code{dans}.>>
#{repe} <<Are repeatitions allowed?>>
#VALUE
# A numeric vector of the positions. It is named with the identifiers.
# When the identifier does not belong to the list and \code{strict} is
# FALSE, NA values are returned.
#EXAMPLE
# r.numero(10:1,1:10);
# r.numero(c("Z","E","P","L","I","N"),LETTERS);
# r.numero(c("B","o","F","!"),LETTERS,strict=FALSE);
# r.numero(c("B","E","B","E"),LETTERS);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_03_09
#REVISED 10_10_12
#--------------------------------------------
{
# checking
qui <- as.character(qui)
dans <- as.character(dans)
if (strict) {
uu <- union(qui,dans)
if (length(uu)!=length(dans)) {
r.erreur(list(setdiff(uu,dans),dans),"Some identifiers does not belong to the list")
}
}
# computing
res <- as.numeric(outer(qui,dans,"==")%*%r.bf(dans))
names(res) <- qui
res[res==0] <- NA
# repetitions
if (!repe) {
rr <- res[!is.na(res)]
if (length(unique(rr)) < length(rr)) {
r.erreur(rr,"Some repetitions were found while forbidden!")
}
}
# returning
res
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.expr3present <- function(sch,ch,exact=FALSE,how="a")
#TITLE indicates inclusion of character string
#DESCRIPTION
# Checks if some string(s) belong(s) to a series of strings.
# When \code{exact} is FALSE, returns TRUE if the
# character string \code{sch} is included at least once
# into the character string \code{ch}.\cr
# \code{sch} can be a vector, in that case, the check is made for each
# of its components. According to \code{how} the returned
# value is vectorial or scalar. When \code{sch} is zero length then
# \code{TRUE} is returned but if not and \code{ch} is zero length
# then \code{FALSE} is returned.
#DETAILS
#PKEYWORDS
#KEYWORDS utilities
#INPUTS
#{sch} <<(\code{character}) the character string(s) to be found.>>
#{ch} <<(\code{character}) the character string(s) to investigate.>>
#[INPUTS]
#{exact} << When exact, one component must
# be strictly identical, if not a subtring is sufficient.>>
#{how} << Indicates what to do when \code{length(sch)>1}. The choice are
# \code{'v'}: a logical vector gives back each check independently;
# \code{'1'}: returns \code{TRUE} when at least one of the component belongs
# to the series \code{ch} and \code{'a'} when all components must comply to get TRUE.>>
#VALUE A logical vector with length of \code{sch}.
#EXAMPLE
# r.expr3present('a','non');
# r.expr3present('o',c('non','oui'));
# r.expr3present(c("o","oui"),c('non','oui'));
# r.expr3present(c("o","oui"),c('non','oui'),how="v");
# r.expr3present(c("A[SEX]","A[AGE]"),c("A[AGE]","A[SEX]"),how="a")
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 08_08_28
#REVISED 12_05_16
#--------------------------------------------
{
#
# degenerate cases
if (length(sch)==0) { return(TRUE);}
if (length( ch)==0) { return(FALSE);}
#
#
res <- logical(length(sch))
#
for (ii in r.bf(sch)) {
if (exact) {
res[ii] <- sum(sch[ii]==ch) > 0
} else {
res[ii] <- length(grep(sch[ii],ch)) > 0
}
}
# dealing with scalar cases
if (how == "1") { res <- any(res);}
if (how == "a") { res <- all(res);}
# returning
res
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
r.form3repeat <- function(cha="-",nb=10,imp=FALSE,cr=imp)
#TITLE prints a repeated given string
#DESCRIPTION
# Without adding breaking line characters, prints
# \code{nb} times a given string of characters
#DETAILS
#PKEYWORDS
#KEYWORDS print
#INPUTS
#[INPUTS]
#{cha} << The string to repeat>>
#{nb} << Number of repetitions>>
#{imp} << Printing when TRUE or returning (default)>>
#{cr} << Must a line feed be added?>>
#VALUE
# character string or printing according to \code{imp}
#EXAMPLE
# r.form3repeat('-+',20,TRUE)
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_24
#REVISED 08_09_25
#--------------------------------------------
{
nb <- max(0,round(nb))
res <- ""
for (jbd in r.bc(nb)) { res <- paste(res,cha,sep="");}
if (cr) { res <- paste(res,"\n",sep="");}
if(!imp) { return(res);}
cat(res)
invisible()
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Try the rbmn package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.