Nothing
inst/original/g4n1.code.r
In g4n: graph for networks
rbsb3k("reset");
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
g4n3k <- function(whi)
#TITLE assigns the constants for the g4n layer
#DESCRIPTION
# defines or returns the constants used within /rbsbgn/.
# The performed action depends on the argument.
#DETAILS
# All constant names start with 'g4n.'.
# This solution was adopted to replace
# a set of global constants that I had difficulty
# to make acceptable with R packages standards.
# It is recommended not to modify these constants
# unless you are completely aware of the consequences.\cr
# The constants can be any object type.
#PKEYWORDS helpful
#KEYWORDS misc
#INPUTS
#{whi} <<a character(1) indicating either to reset or
# to return the names or the current values. The possible
# values are \code{RESET}, \code{reset}, \code{names}, \code{definitions} or \code{values}.>>
# >>
#[INPUTS]
#VALUE
# When \code{whi=="RESET"} nothing (but the assignments are
# performed for all layers \code{rbsb} and \code{g4n}).
# When \code{whi=="reset"} nothing (but the assignments of
# the layer \code{g4n} are performed).
# When \code{whi=="names"} the names as a character vector.
# When \code{whi=="definitions"} the definitions as a named character vector.
# When \code{whi=="values"} the values through a named list.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(g4n.msi);
## to get the short labels
# g4n3k("names");
## to obtain the current values
# g4n3k("values");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_13
#REVISED 09_11_05
#--------------------------------------------
{
# checking
if (!(whi %in% c("RESET","reset","names","definitions","values"))) {
print.default(whi);
stop("g4n3k does not accept this argument");
}
#
if (whi=="RESET") { rbsb3k("RESET");}
#
# definition of the different constants
sc <- character(0);
sc["mck"] <- "Must systematic checks be done?";
sc["mwa"] <- "Must warning be simple warning?";
sc["msi"] <- "g4n signature";
sc["arc0"] <- "null /arc/";
sc["pam0"] <- "null /pam/";
sc["pam1"] <- "Example 1 of /pam/";
sc["pos0"] <- "current /pos/";
sc["pgr0"] <- "current /pgr/";
sc["gn0"] <- "null /gn/";
sc["gn1"] <- "Example 1 of /gn/";
sc["gn2"] <- "Example 2 of /gn/";
sc["gn3"] <- "Example 3 of /gn/";
sc["gn4"] <- "Example 4 of /gn/";
sc["gn5"] <- "Example 5 of /gn/";
sc["gn6"] <- "Example 6 of /gn/";
sc["gn7"] <- "Example 7 of /gn/";
#
# returning the names
#
if (whi=="names") { return(names(sc));}
#
# returning the definitions
#
if (whi=="definitions") { return(sc);}
#
# returning the values
#
if (whi=="values") {
res <- vector("list",0);
for (ii in bf(sc)) {
noco <- names(sc)[[ii]];
cat(noco,"\n");
eee <- paste("res[[\"",noco,"\"]] <- g4n.",noco,";",sep="");
eval(parse(text=eee));
}
return(res);
}
#
# loading the standard values
#
if (tolower(whi)=="reset") {
#
assign("g4n.mck", TRUE,pos=".GlobalEnv");
assign("g4n.mwa", TRUE,pos=".GlobalEnv");
assign("g4n.msi","/g4n/",pos=".GlobalEnv");
#
assign("g4n.arc0",new("arc",nbn=0,fle=matrix(NA,0,3)),pos=".GlobalEnv");
assign("g4n.pam0",new("pam",rlt=matrix(NA,0,0)),pos=".GlobalEnv");
assign("g4n.pam1",new("pam",rlt=matrix(c(rep(0,10),1,1,0,rep(c(0,0,0,0,1),2),1,0),5)),pos=".GlobalEnv");
assign("g4n.pos0",new("pos",
posi=matrix(NA,0,4),
view=c(0,0),
zoom=c(0,0,0,1)
),pos=".GlobalEnv");
assign("g4n.pgr0",new("pgr"),pos=".GlobalEnv");
#
assign("g4n.gn0",new("gn",
description=char2des("Null /gn/"),
nom=rbsb.nom0,
item="n",
pos=g4n.pos0,
arc=g4n.arc0,
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn1",new("gn",
description=char2des("Example 1 of /gn/"),
nom=rbsb.nom1,
item="n",
pos=new("pos",posi=matrix(c(1,2,1,1,2,2,0,0,0,2,1,1),3)),
arc=new("arc",nbn=3,fle=matrix(c(1,2,211),1)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn2",new("gn",
description=char2des("Example 2 of /gn/"),
nom=rbsb.nom2,
item="v",
pos=new("pos",posi=matrix(c(1,2,2,2,1,1,2,3,rep(0,4),rep(2,4)),4)),
arc=new("arc",nbn=4,fle=matrix(c(1,2,211),1)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn3",new("gn",
description=char2des("Example 3 of /gn/"),
nom=rbsb.nom3,
item="v",
pos=new("pos",posi=matrix(c(1,2,1,2,1,2,
1,1,2,2,3,3,
rep(0,6),rep(2,6)),6)),
arc=new("arc",nbn=6,fle=matrix(c(1,2,3,4,5,
2,3,4,5,6,
rep(211,5)),5)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn4",new("gn",
description=char2des("Example 4 of /gn/"),
nom=rbsb.nom4,
item="n",
pos=new("pos",posi=matrix(c(1,2,1,2,
rep(0,2),rep(2,2)),2)),
arc=new("arc",nbn=2,fle=matrix(c(1,2,
rep(211,1)),1)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn5",new("gn",
description=char2des("Example 5 of /gn/"),
nom=rbsb.nom5,
item="n",
pos=new("pos",posi=matrix(c(1,2,1,2,
rep(0,2),rep(2,2)),2)),
arc=new("arc",nbn=2,fle=matrix(c(1,2,
rep(211,1)),1)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn6",new("gn",
description=char2des("Example 6 of /gn/"),
nom=new("nom",x=cha2li(letters[1:6],nam=LETTERS[1:6])),
item="n",
pos=new("pos",posi=matrix(c(1,1,1,2,2,2,
1,2,3,1,2,3,
rep(0,6),rep(2,6)),6)),
arc=new("arc",nbn=6,fle=matrix(c(1,4,1,2,5,6,
rep(211,3)),3)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn7",new("gn",
description=char2des("Example 7 of /gn/"),
nom=new("nom",x=cha2li(letters[1:10],nam=LETTERS[1:10])),
item="n",
pos=new("pos",posi=matrix(c(1,1,1,2,2,2,3,3,3,3,
1,2,3,1,2,3,1,2,3,4,
rep(0,10),rep(2,10)),10)),
arc=new("arc",nbn=10,fle=matrix(c(1,1,1,2,8,10,10,5,
2,5,4,3,6, 6, 9,6,
rep(211,8)),8)),
pgr=g4n.pgr0),pos=.GlobalEnv);
}
#
# Completing the series of null objects
rbsb.null <- c(rbsb.null,c("g4n.arc0","g4n.pam0","g4n.pgr0",
"g4n.pos0","g4n.gn0"));
assign("rbsb.null",rbsb.null,pos=.GlobalEnv);
#
# Completing the series of sets of constants
rbsb.pko <- c(rbsb.pko,"g4n");
assign("rbsb.pko",rbsb.pko,pos=.GlobalEnv);
#
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
parcours8gn <- function(gn,blocked=character(0),imon=TRUE)
#TITLE find the ascendances until blocking
#DESCRIPTION
# exploring the parentship, returns a matrix with
# rows associated to nodes giving their ancestors
# until (if possible) the first blocking node
#DETAILS
# In a first step the matrix of chidrenhood is
# calculated which can be expansive when the number
# of nodes is high.
#KEYWORDS
#PKEYWORDS gn genealogy
#INPUTS
#{gn} <<The gn object to be dealt>>
#[INPUTS]
#{blocked} <<(= character(0)) those nodes
# which are reference node for
# blocking>>
#{imon} <<(=TRUE) must blocked node be included?>>
#VALUE
# A square matrix. Its rows corresponds to every node.
# Its columns are associated to possible
# ascendants: 0 if not, 1 if it is. The node itself is not included
# that is the diagonal elements are zero. The row and column order are
# those of iin; the dimnames of this matrix are given by the node names.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# parcours8gn(g4n.gn7);
#REFERENCE
#SEE ALSO genea
#CALLING
#COMMENT
#FUTURE
# It could be more logical (and efficient when the number
# of nodes is important) that the value was a list of vectors
# and not a matrix which can be very sparse.
#AUTHOR J.-B. Denis
#CREATED 07_09_18
#REVISED 09_06_17
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
# initialization
nbno <- nbnv(gn,gn@item); par <- res <- matrix(0,nbno,nbno);
par <- t(arc2pam(gn@arc)@rlt);
if (gn@item=="n") {
moni <- nv2ion(blocked,gn@nom,"n",check=FALSE)@nk;
nnom <- nanv(gn@nom,"n");
} else {
moni <- nv2ion(blocked,gn@nom,"N",check=FALSE)@vk;
nnom <- nanv(gn@nom,"v");
}
# loop for every node
for (jbd in 1:nbno) { if (!is.element(jbd,moni)) {
qui <- numeric(0);
ppp <- which(par[,jbd]==1);
qui <- setdiff(union(qui,ppp),moni);
ajout <- 1;
if (length(qui) > 0) {while (length(ajout) > 0) {
ajout <- numeric(0);
for (jd in 1:length(qui)) {
pp <- which(par[,qui[jd]]==1);
ajout <- setdiff(union(ajout,pp),union(qui,moni));
}
qui <- union(qui,ajout);
}}
res[jbd,qui] <- 1;
}}
# including blocked nodes
if (imon) { for (jbd in 1:nbno) { if (!is.element(jbd,moni)) {
bord <- c(jbd,which(res[jbd,]==1));
if (length(bord) == 0) { erreur("from parcours8gn","Must comprise at least one node!");}
mm <- numeric(0);
for (jd in bord) {
mm <- union(mm,intersect(which(par[,jd]==1),moni));
}
res[jbd,mm] <- 1;
}}}
# returning
dimnames(res) <- list(nnom,nnom);
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
rmnd4gn <- function(gn,nk)
#TITLE removes a series of nodes from a gn object
#DESCRIPTION
# Removing the nodes and arcs associated to them,
# adjusting the slot arc consequently. Awaiting
# for the generalization of item in /gn/s, only
# node /gn/, i.e. gn@item='n' are accepted here.
#DETAILS
# the initial @nom slot is reduced.
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn}<</gn/ object to be modified.>>
#{nk} <<vector of number nodes to remove. Must be
# given in 'nk' form (see nv2ion).>>
#[INPUTS]
#VALUE
# The reduced object gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(rmnd4gn(g4n.gn1,1));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#????
# In fact there is another (also very interesting) way to remove a node; it
# consists not to remove node and associated arcs, but to transform the arcs
# of the parents and children nodes to keep the transmission (more precisely,
# indirect links can become direct ones). Must also be implemented.
#AUTHOR J.-B. Denis
#CREATED 07_09_06
#REVISED 09_10_20
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
# some preparation
if (is.character(nk)) {
nk <- nv2ion(nk,gn@nom,check=FALSE)@nk;
}
items <- gn2item(gn,check=FALSE);
nnrr <- nrow(gn@arc@fle);
if (nnrr > 0) {
aa <- matrix(items[gn@arc@fle[,1:2]],nnrr);
} else { aa <- matrix(NA,0,0);}
nk <- sort(unique(nk));
mk <- setdiff(bf(items),nk);
n2r <- items[nk];
n2k <- setdiff(items,n2r);
# removing the nodes in the slot nom
for (ii in bf(n2r)) {
gn@nom <- rmnd4nom(gn@nom,n2r[ii]);
}
# removing the corresponding positions
gn@pos@posi <- gn@pos@posi[mk,,drop=FALSE];
# removing the corresponding arcs under variable names
# to avoid a difficult permutation to apply
r2r <- numeric(0);
for (ii in bc(nrow(aa))) {
if (!(aa[ii,1] %in% n2k)) { r2r <- c(r2r,ii);}
if (!(aa[ii,2] %in% n2k)) { r2r <- c(r2r,ii);}
}
r2r <- unique(r2r);
r2k <- setdiff(bc(nrow(aa)),r2r);
# here the numbers must be renumbered
nou <- bf(items);
for (ii in bf(items)) {
nou[ii] <- ii - sum(nk < ii);
}
gn@arc@fle <- gn@arc@fle[r2k,,drop=FALSE];
gn@arc@fle[,1:2] <- nou[gn@arc@fle[,1:2]];
gn@arc@nbn <- length(n2k);
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
rmar4gn <- function(gn,ion)
#TITLE removes a series of arcs from a gn object
#DESCRIPTION
# Removing the arcs associated to a subset of nodes,
# but keeping the nodes (contrary to rmnd4gn)
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn}<<object gn defining the pruned graph>>
#{ion} <<vector of nodes the arc of which must be
# be removed, either the names or the
# internal identification.>>
#[INPUTS]
#VALUE
# The reduced object gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# uu <- g4n.gn1;
# print(uu@arc);
# print(rmar4gn(uu,"A")@arc);
#REFERENCE
#SEE ALSO rmnd4gn
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_17
#REVISED 09_06_17
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
# translating into numbers
if (gn@item=="n") {
qui <- nv2ion(ion,gn@nom,"n",check=FALSE)@nk;
} else {
qui <- nv2ion(ion,gn@nom,"N",check=FALSE)@vk;
}
# detecting the arcs to remove
iuq <- numeric(0);
# just removing the related arcs
if (length(qui > 0)) { for (ar in bc(nrow(gn@arc@fle))) {
afr <- gn@arc@fle[ar,1]; ato <- gn@arc@fle[ar,2];
if (is.element(afr,qui) | is.element(ato,qui)) {
iuq <- c(iuq,ar);
}
}}
if (length(iuq) > 0) { gn@arc@fle <- gn@arc@fle[-iuq,,drop=FALSE];}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
gn2item <- function(gn,check=FALSE)
#TITLE returns the item names of a /gn/ object
#DESCRIPTION
# (see slot @item of /gn/.)
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn} <<The gn object.>>
#[INPUTS]
#{check} <<Must checking be undertaken (conditionally
# to \code{g4n.mck}).>>
#VALUE
# a character providing the item names.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# gn2item(g4n.gn1);
# gn2item(g4n.gn2);
# gn2item(g4n.gn7);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
# This function has been produced for future
# evolutions of the /gn/ items. Not only
# nodes or variables as presently.
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 09_05_06
#--------------------------------------------
{
# checking
if (check) { if (g4n.mck) {check4valid(valid8gn(gn));}}
# creating
res <- nanv(gn,gn@item);
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
plot8cgn <- function(gn,xy)
#TITLE draws nodes and arcs of a gn with already computed xy values
#DESCRIPTION
# Internal drawing of plot.gn, isolated because it
# can be used for multiple plots. The plot is supposed
# to be already open and the coordinates of nodes already
# prepared. See plot8gn for the details about decorations.
#DETAILS
# The reason of xy besides the @pos of the gn object is to
# give the possibility of different projections with the
# same positions.
#KEYWORDS
#PKEYWORDS plot gn
#INPUTS
#{gn} <<The gn to plot>>
#{xy} <<Matrix of (x,y) (nbn x 2) coordinates for the nodes.>>
#[INPUTS]
#VALUE
# returns nothing but something is drawn on the open plot
#EXAMPLE
#REFERENCE
#SEE ALSO plot.gn
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_06_27
#REVISED 09_10_20
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
if (!all(dim(xy) == c(nbnv(gn,gn@item),2))) {
erreur(NULL,"xy not consistent in dimensions!");
}
# getting the node/variable names
nom <- gn2item(gn);
# ancillary function(s)
raccou <- function(x0,y0,x1,y1,di=gn@pgr@diar) {
c(geom3pointi(x0,y0,x1,y1,di),
geom3pointi(x1,y1,x0,y0,di));
}
nbno <- nbnv(gn,gn@item);
if (nbno < 2) {
erreur(nbno,"For this number of nodes no graph is issued",w=g4n.mwa);
return(invisible);
}
nbar <- nrow(gn@arc@fle);
# drawing the nodes
for (i in bc(nbno)) {
xx <- xy[i,1]; yy <- xy[i,2];
la <- nom[i]; de <- gn@pos@posi[i,4];
text(xx,yy,la,cex=gn@pgr@cexscale);
if (!is.na(de)) {
tail <- 6*gn@pgr@cexscale;
if (de == 1) { points(xx,yy,pch=22,cex=tail);}
if (de == 2) { points(xx,yy,pch=21,cex=tail);}
}
}
# drawing the arcs
for (i in bc(nbar)) {
n1 <- gn@arc@fle[i,1]; n2 <- gn@arc@fle[i,2];
ax <- raccou(xy[n1,1],xy[n1,2],
xy[n2,1],xy[n2,2]);
# style of the arcs
com <- gn@arc@fle[i,3];
# getting the heads, line type and width of the arrows
code <- com %/% 100; com <- com - 100*code;
code <- round(code); code <- min(max(code,0),3);
lty <- com %/% 10; com <- com - 10*lty;
lty <- round(lty); lty <- min(max(lty,0),6);
lwd <- com; lwd <- min(max(lwd,0.5),5);
arrows(ax[1],ax[2],ax[3],ax[4],
length=gn@pgr@arrowlength,
lwd=lwd,lty=lty,code=code);
}
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
cycles4gn <- function(gn)
#TITLE reduces the graph to the portion with cycles
#DESCRIPTION
# Just removing from the graph those nodes (and
# associated arcs) which cannot belong to a cycle
# because they are extreme (either without parent or
# without children).\cr
#DETAILS
#KEYWORDS
#PKEYWORDS gn genealogy
#INPUTS
#{gn}<<object gn defining the graph>>
#[INPUTS]
#VALUE
# The reduced object gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# cycles4gn(g4n.gn7); # returns the null /gn/
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The graph associated to a BN must reduce to nothing
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_06
#REVISED 07_09_07
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
rn <- 1;
# loop for removing the nodes
while ((rn > 0) & (nbnv(gn,gn@item) > 0)) {
rn <- 0;
nar <- nrow(gn@arc@fle);
nbd <- nbnv(gn,gn@item);
arc <- matrix(0,nbd,2);
if (nar > 0) { for (ar in 1:nar) {
arc[gn@arc@fle[ar,1],1] <- 1;
arc[gn@arc@fle[ar,2],2] <- 1;
}}
crit <- arc[,1]+arc[,2];
retire <- (1:nbd)[crit<2];
rn <- length(retire);
if (rn > 0) { gn <- rmnd4gn(gn,retire);}
}
# null case
if (nbnv(gn,gn@item)==0) { gn <- g4n.gn0;}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
path4gn <- function(gn,n1,n2,quel=1,elono=TRUE)
#TITLE reduces the graph to the portion in between two node sets
#DESCRIPTION
# Just removing from the graph those arcs (and nodes) which
# does not belong to a path going from a node to another one.\cr
# As graph comprising cycles can be introduced, both directions
# can be considered.
#DETAILS
# To get all descendants of n1, it suffices to put n2 as the complete
# set of nodes
#KEYWORDS
#PKEYWORDS gn genealogy
#INPUTS
#{gn} <<The object gn to consider.>>
#{n1} <<First node set to consider>>
#{n2} <<Second node set to consider>>
#[INPUTS]
#{quel} <<(=1) which directions to consider ?
# 1 for n1 to n2; 2 for n2 to n1 and 3
# for both directions>>
#{elono} <<(=TRUE) are eliminated other nodes ?>>
#VALUE
# The reduced object gn.
# Notice that if a node belongs to n1 (n2) but is not
# linked to any node of n2 (n1) it will be eliminated if elono is TRUE.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# path4gn(g4n.gn7,"E","J",3,FALSE);
# plot(path4gn(g4n.gn7,"A",LETTERS[1:10],3,FALSE));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The graph associated to a BN must not have path in both directions
# (because cycles are prohibited)
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_07
#REVISED 07_11_07
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
#
if (!is.element(quel,1:3)) { quel <- 1;}
if (gn@item=="n") {
n1 <- nv2ion(n1,gn@nom,"n",check=FALSE)@nk;
n2 <- nv2ion(n2,gn@nom,"n",check=FALSE)@nk;
} else {
n1 <- nv2ion(n1,gn@nom,"N",check=FALSE)@vk;
n2 <- nv2ion(n2,gn@nom,"N",check=FALSE)@vk;
}
# looking for lignee
if (length(n1)*length(n2) > 0) {
bah <- numeric(0);
lig <- minbar8gn(gn);
for (jbd in 1:2) {
if ((quel==jbd) | (quel == 3)) {
bas <- hau <- numeric(0);
if (jbd == 1) { pa <- n1; en <- n2;}
else { pa <- n2; en <- n1;}
for (i1 in pa) {
bas <- union(bas,which(lig[i1,] >= 0));
}
for (i2 in en) {
hau <- union(hau,which(lig[,i2] >= 0));
}
bah <- union(bah,intersect(bas,hau));
}}
if (elono) {
gn <- rmnd4gn(gn,setdiff(1:nbnv(gn,gn@item),bah));
}
else {
gn <- rmar4gn(gn,setdiff(1:nbnv(gn,gn@item),bah));
}
}
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
gn2path <- function(gn,d,a)
#TITLE returns all paths between two nodes
#DESCRIPTION
# To return all paths between two nodes, this function
# prepares the parentship matrix and calls
# the recursive function pam2path
#DETAILS
#KEYWORDS
#PKEYWORDS gn genealogy
#INPUTS
#{gn} <<a gn object>>
#{d} <<departure node (ion)>>
#{a} <<arrival node (ion)>>
#[INPUTS]
#VALUE
# a list of vectors with all possible paths
# (nodes are identified by iins)
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# gn2path(g4n.gn7,"A","F");
#REFERENCE
#SEE ALSO
#CALLING {pam2path}
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_17
#REVISED 09_06_17
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
# getting the node numbers
d <- nv2ion(d,gn@nom,"n",check=FALSE)@nk;
a <- nv2ion(a,gn@nom,"n",check=FALSE)@nk;
if ((length(d) != 1) | (length(a) != 1)) {
erreur(NULL,"Only ONE departure and ONE arrival nodes!");
}
# constructing the parentship matrix
mg <- arc2pam(gn@arc);
# calling pam2path and returning
pam2path(mg,d,a);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
pam2gn <- function(pam,description=rbsb.des0,
nom=rbsb.cha0)
#TITLE from a pam object generates a gn object
#DESCRIPTION
# From a pam object (parentship matrix) generates a gn object.
# Standard names can be provided for the nodes.
#DETAILS
#KEYWORDS
#PKEYWORDS gn genealogy pam
#INPUTS
#{pam} <<The pam obect>>
#[INPUTS]
#{description} <<(=rbsb.des0) description for the future gn>>
#{nom} <<(=rbsb.cha0) Names for the nodes>>
#VALUE
# a gn object
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# pam2gn(g4n.pam1);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_27
#REVISED 09_10_20
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8pam(pam));}
if (isvide(description)) {
description <-
new("des",name=paste("From",deparse(substitute(pam))));
}
nbno <- nrow(pam@rlt);
if (nbno == 0) {
res <- g4n.gn0;
} else {
if (length(nom) < nbno) { nom <- form3names(nbno);
} else { nom <- nom[1:nbno];}
res <- new("gn",description=description,
nom=char2nom(nom),
item="n",
arc=pam2arc(pam),
pos=new("pos",posi=matrix(0,nbno,4),
zoom=c(0,0,0,1),
view=c(0,0)),
pgr=g4n.pgr0);
res <- position4gn(res);
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
arc4gn <- function(gn,from,to,add=TRUE)
#TITLE adds or remove some arc(s) to or from a gn object
#DESCRIPTION
# Adds [removes] zero, one arc or a series of arcs to [from]
# a gn and returns the gn so modified. When arcs to add already
# exist, nothing is done. When arc to remove does not exist,
# nothing is done.
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn} <<The gn object>>
#{from} <<vector of ion describing the starting nodes of the arcs to add
# or remove. >>
#{to} <<vector of ion describing the ending nodes of the arcs to add
# or remove. >>
#[INPUTS]
#{add} <<(=TRUE) Adding? (or removing).>>
#VALUE
# The modified gn object.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# gn1 <- g4n.gn7;
# gn2 <- arc4gn(gn1,c("A","C"),c("E","E"));
# gg1 <- arc4gn(gn2,"A","B",FALSE);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_28
#REVISED 09_06_17
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
if (length(from) != length(to)) {
erreur(list(from,to),"'from' and 'to' must have equal lengths");
}
# getting a iin coding
if (gn@item=="n") {
ff <- nv2ion(from,gn@nom,"n",check=FALSE)@nk;
tt <- nv2ion(to ,gn@nom,"n",check=FALSE)@nk;
} else {
ff <- nv2ion(from,gn@nom,"N",check=FALSE)@vk;
tt <- nv2ion(to ,gn@nom,"N",check=FALSE)@vk;
}
# modifying the structure
pam <- arc2pam(gn@arc);
add <- add * 1;
for (fl in bf(from)) {
pam@rlt[ff[fl],tt[fl]] <- add;
}
gn@arc <- pam2arc(pam);
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
relation4gn <- function(gn,rel,cl="equal")
#TITLE formats the arc of a gn from a relation matrix
#DESCRIPTION
# From a completely described gn and a matrix of
# scores between all nodes of it, modifies the format
# of the arcs to take into account the strength of
# their relations.
#DETAILS
# (1) No arcs are added, only existing arcs are considered.\cr
# (2) The set of existing arcs is categorized into four
# classes : poor (dashed), small (continuous 1),
# medium (continuous 2) and strong (continuous 3).\cr
# (3) The classes are defined with three limits defined
# by cl. cl = 'equal' divides the arcs into approximately
# four equally numbered categories. cl = 'propto' divides the
# range of categories into four equal scaled categories.
# cl = numeric(3) imposed the three limit to use.\cr
# (4) NA valued arcs by rel are valued as the "minimum - 1"
# before determining the categories.
#KEYWORDS
#PKEYWORDS gn graph
#INPUTS
#{gn} <<The gn to be modified.>>
#{rel} <<The matrix of scores for the relationships. It is
# a non symmetric matrix, rows are considered parents
# of the columns.>>
#[INPUTS]
#{cl}<<(='equal') See the details section.>>
#VALUE The modified gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# g0 <- g4n.gn7;
# nbn <- nbnv(g0,g0@item);
# gg <- relation4gn(g0,matrix(1:nbn^2,nbn));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 08_10_16
#REVISED 08_10_16
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
if (!is.matrix(rel)) {
erreur(rel,"'rel' is expected to be a matrix.");
}
nbn <- nbnv(gn,gn@item);
if (!all(dim(rel) == c(nbn,nbn))) {
erreur(c(dim(rel),nbn),"Non compatible dimension for matrix rel.");
}
# extracting the fle matrix
fle <- gn@arc@fle;
# extracting the corresponding score values
kk <- fle[,1] + nbn*(fle[,2]-1);
sco <- rel[kk];
# replacing the missing values
if (sum(!is.na(sco)) == 0) {
erreur(rel,"All relations of use are NA!");
}
mii <- min(sco,n.rm=TRUE);
sco[is.na(sco)] <- mii - 1;
# preparing the class limitis
if (is.character(cl)) {
if (cl == "propto") {
ra <- range(cl);
cl <- seq(ra[1],ra[2],le=5)[-c(1,5)];
} else {
cl <- quantile(sco,seq(0,1,le=5)[-c(1,5)]);
}
} else {
if (!is.numeric(cl)) {
erreur(cl,"cl must be character or numeric.");
} else {
if (length(cl) == 3) {
cl <- sort(cl);
} else { erreur(cl,"cl must be of length 3");}
}
}
# modifying the format of the arcs
cla <- 1 + (sco > cl[1]) + (sco > cl[2]) + (sco > cl[3]);
lar <- 1 + (sco > cl[2]) + (sco > cl[3]);
typ <- 1 + (sco <= cl[1]);
gn@arc@fle[,3] <- 200 + 10*typ + lar;
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
list2gn <- function(li)
#TITLE transforms a consistent list into a new /gn/ 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 /gn/ object...
# The main use of this function is to generate /gn/ read from text files
# with the function \code{read8gn}.
#DETAILS
# When \code{$item} does not exist, \code{@item} is computed
# from \code{$posi} if it exists if not from \code{$arc}.
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{li} <<The list to be transformed into a /gn/ object.
# Compulosory component is \code{$name}.
# Usual component is \code{$arc}.
# Possible components are \code{$posi} for the positions,
# \code{$item} for the node/variable names.
#[INPUTS]
#VALUE
# The generated /gn/ object
#EXAMPLE
# g4n3k("RESET"); # for R checking need
# print(list2gn(list(name="a",item=c("A","B"))));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_06
#REVISED 10_06_17
#--------------------------------------------
{
# checking
if (g4n.mck) {
check4tyle(li,"list",-1,message="The first argument must be a list");
}
#
# getting the gn description
na <- li$name;
if (isvide(na)) { erreur(li,"$name is compulsory");}
des <- list2des(li);
# getting the /nom/ of the /gn/
if (!isvide(li$item)) {
itou <- li$item
} else {
if (!isvide(li$posi)) {
itou <- names(li$posi);
} else {
if (!isvide(li$arc)) {
itou <- li$arc;
itou <- paste(itou,collapse=">");
itou <- form3etsil(itou,OPA="",CPA="",
opa="",cpa="",sep=">");
itou <- sort(unique(itou));
} else {
itou <- rbsb.cha0;
}
}
}
nom <- char2nom(itou);
itou <- nanv(nom,0);
nbi <- length(itou);
#
# getting the type of the items
if (identical(nanv(nom,-1),itou)) {
item <- "n";
} else { item <- "v";}
#
# getting the arc slot
fle <- matrix(NA,0,2);
for (ll in bf(li$arc)) {
lu <-li$arc[ll];
lulu <- form3decadre(strsplit(lu,">",fixed=TRUE)[[1]]);
if (length(lulu) > 1) {
if (length(unique(c(lulu,itou)))!=length(itou)) {
erreur(list(itou,lulu),"Not all 'lulu' components are identified items");
}
nunu <- as.vector(outer(lulu,itou,"==") %*% bf(itou));
fle <- rbind(fle,cbind(nunu[-length(nunu)],nunu[-1]));
} else {
erreur(lulu,"This string does not indicate an arc... as expected");
}
}
if (nrow(fle)>0) { fle <- cbind(fle,211);
} else { fle <- matrix(NA,0,3);}
arc <- new("arc",nbn=nbi,fle=fle);
#
# introducing the positions
if (isvide(li$pos)) {
kmi <- 1; while(kmi*kmi < nbi) { kmi <- kmi+1;}
pos <- cbind(rep(1:3,3),rep(1:3,each=3))[sample(kmi*kmi,nbi,replace=FALSE),];
} else {
if ((length(unique(names(li$pos),itou)) > nbi) |
(length(li$pos) != nbi)) {
erreur(list(nom,names(li$pos)),"Bad correspondence between items and positions");
}
# including the proposed positions
nbco <- length(form3etsil(li$pos[[1]],
OPA="",CPA="",opa="",cpa="",
sep=" "));
pos <- matrix(NA,0,nbco);
for (pp in names(li$pos)) {
upp <- form3etsil(li$pos[[pp]],
OPA="",CPA="",opa="",cpa="",
sep=" ");
if (nbco != length(upp)) {
erreur(list(pp,li$pos),"The 'pp' component has got a different lenght that the other ones");
}
pos <- rbind(pos,upp);
}
}
if (any(is.na(as.numeric(pos)))) {
erreur(li$pos,"Not all values are numeric!");
}
pos <- matrix(as.numeric(pos),ncol=ncol(pos));
if (ncol(pos)<2) {
erreur(li$pos,"At least the two coordinates are expected");
}
if (ncol(pos)==2) { pos <- cbind(pos,0);}
if (ncol(pos)==3) { pos <- cbind(pos,2);}
pos <- new("pos",posi=pos);
# building it up
gn <- new("gn",description=des,nom=nom,item=item,
pos=pos,arc=arc,pgr=g4n.pgr0);
# checking the result
if (g4n.mck) {check4valid(valid8gn(gn));}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
gn2list <- function(gn)
#TITLE transforms a /gn/ object into a list
#DESCRIPTION
# Just translating all slot of the /gn/ into
# associated components of a list.
# This is the reverse function of \code{list2gn}.
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn} <<The /gn/ to be transformed into a list.>>
#[INPUTS]
#VALUE
# The generated list
#EXAMPLE
# g4n3k("RESET"); # For R checking compliance
# gn2list(g4n.gn3);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_06_22
#REVISED 10_06_22
#--------------------------------------------
{
# some checks
if (g4n.mck) {
che <- valid8gn(gn);
if (!identical(che,TRUE)) {
erreur(che,"/gn/ is not valid");
}
}
#
# initializing the list
res <- vector("list",0);
#
# getting the gn description
for (dd in slotNames("des")) {
res[[dd]] <- slot(gn@description,dd);
}
#
# getting the items
if (gn@item=="n") {
nbit <- nbnv(gn,"n");
item <- nv2ion(0,gn@nom,"n")@nn;
} else {
nbit <- nbnv(gn,"v");
item <- nv2ion(0,gn@nom,"v")@nvn;
}
res$item <- item;
#
# getting the arcs
res$arc <- rbsb.cha0;
for (aa in bc(nrow(gn@arc@fle))) {
iaa <- gn@arc@fle[aa,1:2];
res$arc <- c(res$arc,paste(item[iaa[1]],">",
item[iaa[2]],sep=""));
}
#
# getting the positions
res$pos <- vector("list",0);
for (pp in bc(nbit)) {
res$pos[[item[pp]]] <- paste(gn@pos@posi[pp,],collapse=" ");
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
write8gn <- function(gn,fi=rbsb.fou,ap=FALSE)
#TITLE writes a /gn/ to file
#DESCRIPTION
# writes a /gn/ objects to a file to be
# readable with \code{read8gn}
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn} <<The /gn/ to be written.>>
#[INPUTS]
#{fi} <<name of the file to be written.
# When \code{rbsb.cha0} no file is
# written but a charecter is returned.>>
#{ap} <<Must an existing file be appended?>>
#VALUE
# nothing but a file is created or modified
#EXAMPLE
# g4n3k("RESET"); # For R checking compliance
# write8gn(g4n.gn3);
# readLines(rbsb.fou);
# unlink(rbsb.fou);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_06_22
#REVISED 10_06_30
#--------------------------------------------
{
# some checks
if (g4n.mck) {
che <- valid8gn(gn);
if (!identical(che,TRUE)) {
erreur(che,"/gn/ is not valid");
}
}
#
# creating the list
lili <- gn2list(gn);
#
# adapting the list for a standard use of list2file
#
# writing the file and returning
list2file(lili,fi,
tags=rbsb.tag2,
ap=ap);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
position4gn <- function(gn,heur="a")
#TITLE proposes positions for the nodes of a gn object
#DESCRIPTION
# Following some heuristics computes new positions for a /gn/
#DETAILS
#KEYWORDS
#PKEYWORDS gn plot
#INPUTS
#{gn} <<gn object>>
#[INPUTS]
#{heur} <<(='a') indicates which heuristic must be used.
# (a) for acp on the arc,
# (h) adapted for hierarchical trees from roots,
# (h2) idem but with vertical alternance,
# (H) adapted for hierarchical trees from leafs,
# (H2) idem but with vertical alternance.
#VALUE
# The same 'gn' object with the new positions
#REFERENCE
#FUTURE
# Ideas for more heuristics
#{*} <<add two other axes>>
#{*} <<Random>>
#{*} <<on a lattice with some heuristic>>
#{*} <<on concentric circles around a given node,
# possibly chosen for its properties>>
#{*} <<take into account the direction of arcs>>
#SEE ALSO
#CALLING
#COMMENT
# The algorithm does not seem very effective! Think about other ideas.
#AUTHOR J.-B. Denis
#CREATED 07_05_22
#REVISED 09_10_16
#--------------------------------------------
{
# some checks
if (g4n.mck) {check4valid(valid8gn(gn));}
heurp <- c("a","h","h2","H","H2");
if (sum(heur==heurp)!=1) {
erreur(list(heur,heurp),"argument 'heur' took an inexpected value");
}
# constructing the relationship matrix
eps <- 0.00001;
np <- nbnv(gn,gn@item);
if (np <= 0) {return(gn);}
if (heur=="a") {
fleches <- gn@arc@fle;
if (nrow(fleches) > 0) {
rrr <- matrix(0,np,np);
for (i in 1:np) { rrr[i,i] <- 2;}
for (i in 1:nrow(fleches)) { rrr[fleches[i,1],fleches[i,2]] <- 1;}
rrr <- rrr + t(rrr) + eps;
# deducing a distance matrix
rrr <- 1/rrr - 1/max(rrr);
# centring the distance matrix
uu <- apply(rrr,1,mean);
nn <- rep(1,np);
rrr <- rrr - outer(uu,nn) - outer(nn,uu) + mean(rrr);
# finding its first singular vector
vv <- svd(rrr)$u[,1];
# deducing the order
oo <- order(vv);
}
else { # no arc
oo <- 1:np;
}
# computing the new positions
theta <- (1:np)*2*pi/np;
theta <- theta[oo];
gn@pos@posi <- cbind(cos(theta),sin(theta),0,0);
gn@pos@zoom <- c(0,0,0,1);
gn@pos@view <- rep(0,2);
}
#
if (heur%in% c("h","h2","H","H2")) {
root <- expr3present("h",heur);
altv <- expr3present("2",heur);
if (cycle8pam(gn@pam)) {
erreur(gn,paste("This graph has got cycle(s), use another heurisitics that",heur));
}
ax <- function(x) { if(diff(range(x))>0) {(x-min(x))/(max(x)-min(x));}else{0.5;}}
# finding the roots
nbn <- nbnv(gn,gn@item);
nopla <- ends8gn(gn);
roots <- c(nopla$RwL,nopla$RaL);
leaves <- c(nopla$LwR,nopla$RaL);
if (length(roots) == 0) {
rapport("No root for this gn but no cycles were previously detected?");
}
if (length(leaves) == 0) {
rapport("No leave for this gn but no cycles were previously detected?");
}
# finding the minimum distance to the roots or leaves as ordinates
dd <- minbar8gn(gn);
dd[dd<=0] <- max(dd);
X <- Y <- rep(NA,nbn);
Y[roots] <- 0;
for (ii in bc(nbn)) { if (is.na(Y[ii])) {
Y[ii] <- min(dd[roots,ii]);
}}
# scoring successively the abscissae
X[roots] <- ax(bf(roots));
nbe <- max(Y);
for (ii in bc(nbe)) { if (length(Y==ii)>0) {
qq <- which(Y==ii);
rr <- rep(0,length(qq));
for (jj in bf(qq)) {
jjj <- qq[jj];
for (kk in bc(nbn)) { if (!is.na(X[kk])) {
rr[jj] <- rr[jj] + X[kk]*(dd[kk,jjj]==ii);
}}
}
X[qq] <- ax(rr);
}}
if (!root) {
# modifying the ordinates accordingly
Y <- NA;
Y[leaves] <- 0;
for (ii in bc(nbn)) { if (is.na(Y[ii])) {
Y[ii] <- min(dd[ii,leaves]);
}}
}
if (altv) {
# alternating vertically
ry <- range(Y);
for (y in ry[1]:ry[2]) {
sel <- which(Y==y);
if (length(sel) > 1) {
qui <- sel[(rank(X[sel]) %% 2) == 0];
Y[qui] <- Y[qui]+0.25;
}
}
}
# constructing the gn
gn@pos@posi <- cbind(X,Y,0,0);
gn@pos@zoom <- c(0,0,0,1);
gn@pos@view <- rep(0,2);
}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
plot3D8gn <- function(gn,...)
#TITLE plots an object gn according to its 3 dimensions
#DESCRIPTION
# The figure is divided into 4 quadrants, 3 of them are used to
# draw the graph according to its (X,Y), (X,Z) and (Z,Y) coordinates
#DETAILS
#KEYWORDS
#PKEYWORDS plot gn
#INPUTS
#{gn} <<the gn to plot>>
#[INPUTS]
#{...} <<to give when first calling to the standard plot function>>
#VALUE
# returns nothing but a plot is drawn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# plot3D8gn(g4n.gn7);
#REFERENCE
#SEE ALSO
#CALLING {plot8cgn}
#COMMENT
#FUTURE
# In the last quadrant, plots the ACP with the first two axis derived
# from the pseudo-distance given by mindis8pam (or pam matrix)...
#AUTHOR J.-B. Denis
#CREATED 07_07_17
#REVISED 07_11_07
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
# preparing the plots
nbno <- length(gn@nom);
mm <- 0.1; ra <- rep(NA,3);
for (i in 1:3) { ra[i] <- diff(range(gn@pos@posi[,i])); }
ma <- mm*ra;
mi <- ra[3]+2*ma[3];
xr <- c(0,ra[1]+2*ma[1]+mi);
yr <- c(0,ra[2]+2*ma[2]+mi);
plot(0,0,xlim=xr,ylim=yr,type="n",
axes=FALSE,xlab="",ylab="",...);
# axis
text(xr[2],mi,"X",cex=3);
text(mi,yr[2],"Y",cex=3);
text(xr[1],mi,"Z",cex=3);
text(mi,yr[1],"Z",cex=3);
abline(h=mi);abline(v=mi);
# last quadrant
xgr <- mi/2; ygr <- mi/2;
tgr <- paste(nbno,"nodes and",nrow(gn@arc@fle),"arcs");
text(xgr,ygr,tgr);
# drawing nodes and arcs (X,Y)
gd <- gn;
calage <- c(mi+ma[1]-min(gd@pos@posi[,1]),
mi+ma[2]-min(gd@pos@posi[,2]));
xy <- gn@pos@posi[,1:2] +
matrix(calage,nbno,2,byrow=TRUE);
plot8cgn(gd,xy);
# drawing nodes and arcs (X,Z)
gd <- gn;
calage <- c(mi+ma[1]-min(gd@pos@posi[,1]),
ma[3]-min(gn@pos@posi[,3]));
xy <- gn@pos@posi[,c(1,3)] +
matrix(calage,nbno,2,byrow=TRUE);
plot8cgn(gd,xy);
# drawing nodes and arcs (Z,Y)
gd <- gn;
calage <- c(ma[3]-min(gd@pos@posi[,3]),
mi+ma[2]-min(gd@pos@posi[,2]));
xy <- gn@pos@posi[,c(3,2)] +
matrix(calage,nbno,2,byrow=TRUE);
plot8cgn(gd,xy);
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
rgn <- function(des,type="hier",
nno=c(5,10),nar=c(10,20),
nom=LETTERS,dire="nat",lev=1)
#TITLE creates a pseudo-random gn object
#DESCRIPTION
# Creates a gn object which characteristics are
# randomly generated following the requirements of the call.
# Also positions illuminating the struture are proposed.
# Normally the produced gn is connected and without cycles.
# When the request is not possible, a warning is issued and
# some compatible option is provided. Using this function with
# the same set.seed starting point (and the same request) must
# produce identical gn.\cr
# Different types of gn are possible, their characteristics
# are given by arguments and pseudo-randomness. The type argument
# describes the structure of the links without care about the
# directions (as edges). The possible types are:\cr
#{chain} <<All nodes are aligned in a simple chain. So a relationship
# exists between nno and nar: nno = nar +1. Then nno will
# be drawn and nar deduced.>>
#{ring} <<Like the chain type but a cycle is done with the
# relationships and nno = nar.>>
#{hier} <<A hierarchy in the sense that the nodes can be disposed in
# a dendrogram structure; a particular case of this is the "star"
# structure when there only a branching point and the branches can
# comprise several nodes.>>
#{audit} <<A hierarchy with two levels. For this specific case, 'nno' is
# the number of grouping levels and 'nar' is the number of
# terminal nodes for each grouping levels. Names of nodes are
# determined accordingly.>>
#{square} <<Not so simple to describe. Nodes are placed in the cell of
# square matrix and edges between nodes respects this structure.
# Arcs (including their number) are deduced from the node
# positions. Run some cases and you will understand seing the
# plot.>>
#{tetra} <<Four of the nodes are on the vertices of a tetrahedron and the
# other nodes are on its edges.>>
#{total} <<The maximum number of arcs, nno*(nno-1)/2, is provided.
# So nar will not be considered.>>
# It is suggested that the seed be initialized before calling this function.
#DETAILS
# Of course if too much arcs are ordered, the probability of a
# non-cycle graph may be very small, even null.\cr
# To prevent this, a local nb_trial limits the number of draws,
# if this limit is reached then a fatal error is issued.\cr
# For some type (e.g. "square"), the ordered number of arcs and nodes
# may not be respected for some reasons.
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{des} <<Either the name or the description (preferably) for the
# newly created gn.>>
#[INPUTS]
#{type} <<type of the gn, see the description field for details>>
#{nno} << range within which must be the number of nodes. Of course
# the range can be null, in that case the number of nodes is directly
# provided by the user. If not, it is drawn according to a uniform
# distribution (one integer from \code{nno[1]} to \code{nno[2]}).\cr
# Single values are repeated, e.g \code{5} becomes \code{c(5,5)}.
# When audit, it gives the number of grouping nodes.>>
#{nar} << range within which must be the number of arcs. Similar
# to \code{nno} but \code{nno} being fixed \code{nar} must satisfy some constraints. These
# constraints may also depend on the \code{type} of /gn/.\cr
# When audit, it gives the number of nodes for each grouping nodes.\cr
# Single values are repeated, e.g \code{5} becomes \code{c(5,5)}.>>
#{nom} <<vector of names to be used for the nodes.>>
#{dire} << indicates the directions of the arcs between the
# nodes of a /gn/. There are two possibilities: "nat" for natural
# directions and "ran" for random under the restriction of no
# cycles.\cr
# For 'audit' the two choices are 'nat' for putting the first node
# as root else it will be the synthesis.\cr
# No effect when type ="ring".>>
#{lev} << maximum level of hierarchy; only used when \code{type} is "hier".>>
#VALUE
#EXAMPLE
# set.seed(1234);
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# r1 <- rgn(char2des("r1"),type="hier");
# r2 <- rgn(char2des("r2"),type="square");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
# It is good to have only ONE rgn function, so that this one
# can generate a large variety of gns. Nevertheless, it is not
# that easy that the same collection of argument can apply to
# every one. An idea for the future could be to have only three
# arguments : des, type and argu where argu is a list where the
# components might be different according to the type.
#AUTHOR J.-B. Denis
#CREATED 07_10_08
#REVISED 10_06_09
#--------------------------------------------
{
# some precautions
nno <- round(range(nno)); nar <- round(range(nar));
if (min(c(nno,nar)) < 1) {
erreur(list(nno,nar),"At least one node and one arc are necessary!");
}
#
if (type=="audit") {
# a new type differently based
## determining the number of grouping nodes
if (nno[1]==nno[2]) {nbgn <- nno[1];
} else { nbgn <- sample(nno[1]:nno[2],1);}
## determining the number of nodes within each
if (nar[1]==nar[2]) { nbno <- rep(nar[1],nbgn);
} else {
nbno <- sample(nar[1]:nar[2],nbgn,replace=TRUE);
}
## determining the names of the nodes
nbn <- 1+nbgn+sum(nbno);
if (length(nom) >= nbn) { noms <- nom[1:nbn];
} else {
noms <- rep(NA,nbn);
if (dire=="nat") { noms[1] <- "<<SYNTH>>";
} else { noms[1] <- "<<ROOT>>";}
noms[1+1:nbgn] <- form3names(nbgn);
KK <- 1+nbgn;
for (i in 1:nbgn) {
noms[KK+1:nbno[i]] <- paste(noms[1+i],"(",1:nbno[i],")",sep="");
KK <- KK + nbno[i];
}
noms[1+1:nbgn] <- paste("<",noms[1+1:nbgn],">",sep="");
}
## determining the positions
posi <- matrix(0,nbn,4);
posi[1,1] <- 1;
posi[1+1:nbgn,2] <- -1;
posi[1+1:nbgn,1] <- (-1/2 + (1:nbgn))*2/nbgn;
posi[-c(1:(nbgn+1)),2] <- -2;
posi[-c(1:(nbgn+1)),1] <- (-1/2 + (1:sum(nbno)))*2/sum(nbno);
## determining the arcs for this gn
nbar <- nbn-1;
mar <- new8arc(nbn,nbar);
mar@fle[1:nbgn,1:2] <- c(rep(1,nbgn),1+1:nbgn);
KK <- nbgn;
for (i in 1:nbgn) {
mar@fle[KK+1:nbno[i],1] <- rep(1+i,nbno[i]);
mar@fle[KK+1:nbno[i],2] <- 1+KK + (1:nbno[i]);
KK <- KK + nbno[i];
}
if (dire == "nat") {
uu <- mar@fle[,1];
mar@fle[,1] <- mar@fle[,2];
mar@fle[,2] <- uu;
}
pos <- new("pos",posi=posi,zoom=c(0,0,0,1),view=c(0,0));
## returning
gg <- new("gn",
description=char2des(des),
nom=char2nom(noms),
item="n",
arc=mar,
pos=pos,
pgr=g4n.pgr0);
return(gg);
}
# trying to avoid cycles
nb_trial <- 1000;
# numbers of nodes and arcs
if (nno[1] == nno[2]) { nbno <- nno[1];
} else { nbno <- sample(nno[1]:nno[2],1);}
if (type %in% c("chain","hier")) { nbar <- nbno - 1;
} else {
if (type == "ring") { nbar <- nbno;
} else {
if (type == "total") { nbar <- nbno*(nbno-1)/2;
} else {
if (nar[1] == nar[2]) { nbar <- nar[1];
} else { nbar <- sample(nar[1]:nar[2],1);}
}
}
}
# names for the nodes
if (length(nom) < nbno) { nom <- form3names(nbno);
} else { nom <- nom[1:nbno];}
# the different types
ltype <- c("chain","ring","hier","square","tetra","total","audit");
if (!(type %in% ltype)) {
cat("You ask a gn of type",type,"but this type is not yet implemented\n");
cat("Available type are:",ltype,"\n");
erreur(NULL,"type not available!");
}
if (nbar > nbno*(nbno-1)/2) {
nbar <- nbno*(nbno-1)/2 - 1;
}
mar <- new8arc(nbno,nbar);
posi <- matrix(0,nbno,4);
lim <- matrix(NA,2,3);
vie <- rep(0,2);
if (type == "chain") {
for(jbd in 1:nbar) {
if (dire == "nat") { fle <- c(jbd,jbd+1);
} else { fle <- sample( c(jbd,jbd+1),2);}
mar@fle[jbd,1:2] <- fle;
}
pp <- arc2pam(mar);
for(jbd in 1:nbno) {
uu <- sum(pp@rlt[jbd,]) - sum(pp@rlt[,jbd]);
posi[jbd,1:3] <- c(jbd,uu,0);
}
}
if (type == "ring") {
mar@fle[nbar,1:2] <- sample(c(nbar,1));
for(jbd in 1:(nbar-1)) {
mar@fle[jbd,1:2] <- sample( c(jbd,jbd+1),2);
}
if(cycle8pam(arc2pam(mar))) { mar@fle[1,1:2] <- mar@fle[1,c(2,1)];}
for(jbd in 1:nbno) {posi[jbd,1:3] <- c(cos(2*pi/nbno*jbd),
sin(2*pi/nbno*jbd),0);}
}
if (type == "hier") {
# parentship
enf <- rep(0,nbno); niv <- rep(NA,nbno); names(niv) <- nom;
enf[1] <- niv[1] <- 0; nbf <- 1;
for (jbd in 2:nbno) { while(is.na(niv[jbd])) {
jd <- sample(which(!is.na(niv)),1);
if ((niv[jd] <= lev) | (enf[jd] == 0)) {
niv[jbd] <- niv[jd] + 1;
enf[jd] <- enf[jd] + 1;
mar@fle[jbd-1,1:2] <- c(jd,jbd);
}
}}
# positions
mmm <- arc2pam(mar);
xx <- yy <- rg <- rep(NA,nbno); names(rg) <- nom;
mlev <- max(niv);
xx[1] <- yy[1] <- 0; rg[1] <- 1;
for (jbd in 1:mlev) {
# dealing with level jbd
qui <- which(niv == jbd);
val <- rep(0,length(qui));
for (jd in bf(qui)) {
che <- pam2path(mmm,1,qui[jd])[[1]];
ch <- che[-length(che)];
for (sd in 1:length(ch)) {
qq <- ch[sd];
val[jd] <- val[jd] + rg[qq]*nbno^(mlev-niv[qq]);
}
}
rg[qui] <- rank(val,ties.method="random");
xx[qui] <- rg[qui] - mean(rg[qui]);
yy[qui] <- -jbd;
}
posi <- cbind(xx,yy,rep(0,nbno),rep(0,nbno));
# randomness
if (dire == "ran") {
for (jbd in 1:nrow(mar@fle)) {
mar@fle[jbd,1:2] <- sample(mar@fle[jbd,1:2],2);
}
}
}
if (type == "square") {
# square size
k <- ceiling(sqrt(nbno));
# ensuring connectedness
ppo <- matrix(0,k,k);
ppo[1,] <- 1:k; ppo[2:k,1] <- (k+1):(2*k-1);
ppo <- ppo[sample(k),sample(k)];
# positionning the remaining nodes
for (jbd in bc(nbno-2*k+1)) {
jd <- jbd + 2*k - 1;
uu <- sample(nbno - jd + 1,1);
vv <- which(ppo == 0)[uu];
ppo[vv] <- jd;
}
# defining arcs and positions
mar <- new8arc(nbno,0);
for (i in bc(k)) { for (j in bc(k)) { if (ppo[i,j] > 0) {
# by column
if (i < k) {
uu <- ppo[(i+1):k,j];
if (sum(uu) > 0) {
qq <- which(uu > 0)[1];
mar@fle <- rbind(mar@fle,c(uu[qq],ppo[i,j],211));
}
}
# by row
if (j < k) {
uu <- ppo[i,(j+1):k];
if (sum(uu) > 0) {
qq <- which(uu > 0)[1];
mar@fle <- rbind(mar@fle,c(uu[qq],ppo[i,j],211));
}
}
posi[ppo[i,j],1:3] <- c(k-j,i,0);
}}}
# randomness
if (dire == "ran") {
for (jbd in 1:nrow(mar@fle)) {
mar@fle[jbd,1:2] <- sample(mar@fle[jbd,1:2],2);
}
ppa <- arc2pam(mar);
nbt <- 1;
while(cycle8pam(ppa)) {
if (nbt > nb_trial) {
erreur(NULL,"Seems difficult not to get cycles!");
}
nbt <- nbt + 1;
for (jbd in 1:nrow(mar@fle)) {
mar@fle[jbd,1:2] <- sample(mar@fle[jbd,1:2],2);
}
ppa <- arc2pam(mar);
}
}
}
if (type == "tetra") {
erreur(type,"to be done");
}
if (type == "total") {
kk <- 0;
for (jbd in 1:(nbno-1)) { for (jd in (jbd+1):nbno) {
kk <- kk+1;
mar@fle[kk,1:2] <- c(jbd,jd);
}}
for(jbd in 1:nbno) {posi[jbd,1:3] <- c(cos(2*pi/nbno*jbd),
sin(2*pi/nbno*jbd),0);}
}
# returning
pos <- new("pos",posi=posi,zoom=c(0,0,0,1),view=c(0,0));
#
gg <- new("gn",
description=char2des(des),
nom=char2nom(nom),
item="n",
arc=mar,
pos=pos,
pgr=g4n.pgr0);
gg;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
modify4gn <- function(gn)
#TITLE interactive modifications of a gn
#DESCRIPTION
# graphical interface to modify (i) the positions,
# (ii) the arcs and (iii) the nodes of an object of class gn.
# Besides, it provides the facility to change the viewpoint
# from which is drawn the graph (positions of a gn object
# are defined in R to the 3).
# \cr The modified gn is returned.
#\cr
# To exit, just click the grey button 'E'
#\cr
# Action are started by the left hand buttons. Their codes are:\cr
# "rst" for resetting (cancel all modifications),\cr
# "MN" for moving the position of a node (the user must click
# twice: for indicating the node and then the new desired
# position),\cr
# "AA" for adding an arc (the user must click twice to indicate the
# starting node then the ending node), \cr
# "RA" for removing an existing arc (the user must click twice to
# indicate the arc to be removed), \cr
# "AN" for adding a node (the user must click once to indicate the
# position of the new node), its name is automatically provided
# but can be changed afterwards, \cr
# "RN" for removing a node (the user must click once, on the node
# to be removed), \cr
# "+" for narrowing the zoom (the user must click once, on the point
# where the zoom must be centered; the zooming coefficient is
# driven by the @pgr@kzoom parameter),\cr
# "-" for widing the zoom (the user must click once, on the point
# where the zoom must be centered; the zooming coefficient is
# driven by the @pgr@kzoom parameter),\cr
# "Rot" for rotating the representation in R to the three (the
# user must click once, in the direction of the rotation and more or less
# close to the center to indicate the angle to perform; the two big
# circles which appears on the diagram are associated to rotations of
# 5 and 10 degrees.
#DETAILS
#KEYWORDS
#PKEYWORDS plot gn
#INPUTS
#{gn} <<the gn object gn to be interactively modifyed.>>
#[INPUTS]
#VALUE
# The modified gn by the actions performed by the user.
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The initial basic algorithm is inspired from some deal function (thanks to them)
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_05_22
#REVISED 09_05_06
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
# defining ancillary functions
quequoi <- function(point) {
if (length(point) != 2) {
erreur(NULL,paste("Expecting TWO coordinates, possibly the",
"graphic device is not open for interactive way?",
"if so, just execute 'dev.off()'"));
}
# returns an integer.
# if negative, it is the number of a pressed button
# if positive, it is the number of the closest node
if ((point[1] >= xre[2]) | (point[1] < xre[1])) {
di <- (point[1] - posbut[,1])^2 + (point[2] - posbut[,2])^2;
res <- -which(min(di) == di)[1];
} else {
di <- (point[1] - gd@pos@posi[,1])^2 + (point[2] - gd@pos@posi[,2])^2;
res <- which(min(di) == di)[1];
}
res;
}
dessinne <- function() {
#######################################################
# recomputing necessary parameters for a new order
#######################################################
newp <- pos2pos(gd@pos);
rara <- range8pos(newp);
# ranges for the graph
xre <- rara$x; yre <- rara$y;
# global ranges
mx <- (xre[2] - xre[1])*pbut;
xr <- c(xre[1]-mx,xre[2]+mx);
my <- (yre[2] - yre[1])*pbut;
yr <- c(yre[1]-my,yre[2]+my);
# indicating the view
xvi <- (xr[1]+xre[1])/2;
yvi <- yre[1] + 4*my;
tvi <- paste("Theta =",
round(gd@pos@view[1]*180/pi),"deg.",
" and Phi =",
round(gd@pos@view[2]*180/pi),"deg.");
# indicating the graph
xgr <- xre[1] + 4*mx;
ygr <- (yr[2]+yre[2])/2 + my*0.3;
tgr <- paste(nbno,"nodes and",nrow(gd@arc@fle),"arc(s)",
" {{{",round(gd@pos@zoom[4],1),"}}}");
# indicating the contextual message
xme <- xre[1] + 4*mx;
yme <- (yr[1]+yre[1])/2 - my*0.3;
# defining the positions and the sizes of the buttons
posbut <- sizbut <- matrix(NA,nbut,2);
for (i in 1:(nbut-1)) {
posbut[i,1] <- (xre[2]+xr[2])/2;
posbut[i,2] <- yre[2] - i*my*1;
sizbut[i,1] <- mx*kbut;
sizbut[i,2] <- my*kbut;
}
posbut[nbut,1] <- (xre[1]+xr[1])/2;
posbut[nbut,2] <- (yre[1]+yr[1])/2;
sizbut[nbut,1] <- mx*kbut;
sizbut[nbut,2] <- my*kbut;
# defining the color of the buttons
colbut <- matrix(c("white","black"),nbut,2,byrow=TRUE);
# starting the plot
plot(0,0,type="n",#axes=FALSE,
xlim=xr,ylim=yr,
xlab="",ylab="");
# drawing the graph
plot8cgn(gd,newp@posi[,1:2]);
# adding a working frame
abline(h=yre,lty=3); abline(v=xre,lty=3);
# displaying the projection view
text(xvi,yvi,tvi,srt=90);
# displaying the graph traits
text(xgr,ygr,tgr);
# displaying the contextual message
text(xme,yme,messa[message]);
# displaying the buttons
colbut[nbut,1] <- "gray";
for (jd in 1:(nbut-1)) {
if (mode==conbut[jd]) {colbut[jd,] <- c("black","white");
} else { colbut[jd,] <- c("white","black"); }
}
for (jbd in 1:nbut) {
symbols(posbut[jbd,1],posbut[jbd,2],
rectangles=matrix(sizbut[jbd,],1,2),
bg=colbut[jbd,1],
add=TRUE,inches=FALSE);
text (posbut[jbd,1],posbut[jbd,2],
labels=conbut[jbd],col=colbut[jbd,2]);
}
list(xre=xre,yre=yre,posbut=posbut);
}
nbno <- nbnv(gn,gn@item);
# parametering the button sizes and some margin size
pbut <- 0.10; kbut <- 0.8;
# calibration of the rotation
anglemax <- pi/2;
# starting
par(mfrow=c(1,1));
messa <- c("(1/2) Click the node to move",
"(2/2) Click where to move the node",
"(1/2) Click the starting node",
"(2/2) Click the ending node",
"(1/2) Click the starting node",
"(2/2) Click the ending node",
"(1/1) Click where to put the new node",
"(1/1) Click the node to remove",
"(1/1) Click the center of the magnyfication",
"(1/1) Click the center for the reduction",
"(1/1) Click direction and angle of the rotation");
names(messa) <- c("MN","MN2","AA","AA2",
"RA","RA2","AN","RN",
"+","-","Rot");
# intitial mode
mode <- "MN"; message <- "MN";
# defining the contents of the buttons
nbut <- 10;
conbut <- c("rst","MN","AA","RA","AN","RN","+","-","Rot","Exit");
gd <- gn;
### BEGINNING OF MODIFICATION LOOP
while(TRUE) {
#######################################################
# drawing an updated screen
#######################################################
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
########################################################
# according to the mode different actions are awaited
########################################################
# exiting
if (mode == "Exit") { break;}
# resetting
if (mode == "rst") {
gd <- gn; mode <- "MN"; next; message <- mode;
}
# moving a node
if (mode=="MN") {
mode <- "MN"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the node to move
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
}
# we must get the point to move there
message <- "MN2";
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
ou <- unlist(locator(1));
nu <- quequoi(ou);
if (nu < 0) {
if (-nu == nbut) { break;}
mode <- conbut[-nu]; message <- mode;
next;
} else {
gd@pos@posi[ni,1:2] <- ou;
}
}
# adding an arc
if (mode=="AA") {
mode <- "AA"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the starting node
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
}
# we must get the ending node
message <- "AA2";
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
ou <- unlist(locator(1));
nj <- quequoi(ou);
if (nj < 0) {
if (-nj == nbut) { break;}
mode <- conbut[-nj]; message <- mode;
next;
} else {
pam <- arc2pam(gd@arc);
pam@rlt[ni,nj] <- 1;
gd@arc <- pam2arc(pam);
mode <- "AA"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
next;
}
}
# removing an arc
if (mode=="RA") {
mode <- "RA"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the starting node
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
}
# we must get the ending node
message <- "RA2";
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
ou <- unlist(locator(1));
nj <- quequoi(ou);
if (nj < 0) {
if (-nj == nbut) { break;}
mode <- conbut[-nj]; message <- mode;
next;
} else {
pam <- arc2pam(gd@arc);
pam@rlt[ni,nj] <- 0;
gd@arc <- pam2arc(pam);
mode <- "RA"; message <- mode; next;
}
}
# adding a node
if (mode=="AN") {
mode <- "AN"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get where to put a supplementary node
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
} else {
nena <- form3names(1,gn2item(gd));
gd <- and4gn(gd,nena);
gd@pos@posi[nbnv(gd,gd@item),1:2] <- ou;
mode <- "AN"; message <- mode; next;
}
}
# removing a node
if (mode=="RN") {
mode <- "RN"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the node to remove
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
} else {
gd <- rmnd4gn(gd,ni);
mode <- "RN"; message <- mode; next;
}
}
# zooming more
if (mode=="+") {
mode <- "+"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the center point for applying the zoom
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
} else {
ou[1] <- -1 + 2*(ou[1]-min(gd@pos@posi[,1]))/
(max(gd@pos@posi[,1])-min(gd@pos@posi[,1]));
ou[2] <- -1 + 2*(ou[2]-min(gd@pos@posi[,2]))/
(max(gd@pos@posi[,2])-min(gd@pos@posi[,2]));
gd@pos@zoom <- c(ou,gd@pos@zoom[3],gd@pos@zoom[4]*gd@pgr@kzoom);
mode <- "+"; message <- mode; next;
}
}
# zooming less
if (mode=="-") {
mode <- "-"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the center point for applying the zoom
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
} else {
ou[1] <- -1 + 2*(ou[1]-min(gd@pos@posi[,1]))/
(max(gd@pos@posi[,1])-min(gd@pos@posi[,1]));
ou[2] <- -1 + 2*(ou[2]-min(gd@pos@posi[,2]))/
(max(gd@pos@posi[,2])-min(gd@pos@posi[,2]));
gd@pos@zoom <- c(ou,gd@pos@zoom[3],gd@pos@zoom[4]/gd@pgr@kzoom);
mode <- "-"; message <- mode; next;
}
}
# rotating
if (mode=="Rot") {
mode <- "Rot"; message <- mode;
uuu <- dessinne ();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# indicating the center (start for rotation)
# center of the plot and radius
centx <- mean(xre); centy <- mean(yre);
rayon <- sqrt(diff(xre)^2+diff(yre)^2);
for (jd in 1:3) { points(centx,centy,cex=jd);}
# putting calibration rotation of 5 deg. and 10 deg.
symbols(rep(centx,2),rep(centy,2),
circles=0.5*rayon*(diff(xre)/anglemax)*pi/180*c(5,10),
add=TRUE,inches=FALSE);
# we must get Theta and Phi angles
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni];
next;
} else {
theta <- ou[2] / diff(xre) * anglemax;
phi <- ou[1] / diff(xre) * anglemax;
gd@pos@view <- gd@pos@view + c(theta,phi);
gd@pos <- pos2pos(gd@pos);
mode <- "Rot"; next;
}
}
} ### ENDING THE CLICKING GAME
dev.off();
gd;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
read8gn <- function(fi)
#TITLE produced a /gn/ from a text file
#DESCRIPTION
# The text file must follow the structure compatible
# with \code{file2list}. The first component of the file
# must be the description of the /gn/; the remaining
# components are supposed to be the nodes.
#DETAILS
# See \code{rebastaba.etg?.txt} files to get
# straightforward examples.
#KEYWORDS
#PKEYWORDS gn file
#INPUTS
#{fi} <<The name of the file to be considered.>>
#[INPUTS]
#VALUE
# The generated /gn/ object
#REFERENCE
#SEE ALSO
#CALLING {file2list} {list2gn}
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_06
#REVISED 10_06_16
#--------------------------------------------
{
# reading the list
li <- file2list(fi,path="",
tags=rbsb.tag2,
sep=rbsb.sep2
);
## interpreting the list
# exploring it
ee <- explore8list(li);
# looking for all the components
ve <- bc(nrow(ee));
for (ii in bc(nrow(ee))) {
# eliminating the list ones
ve[ee[,"classes"] == "list"] <- 0;
nam <- ee[ii,"name"];
# eliminating the list ones
if (nam == "list") {ve[ii] <- 0;
# if not getting the components
} else { vava <- get8listcomp(li,ee[ii,])[[1]];}
#
# dealing with compulsory character of the description
if (expr3present(nam,c("name","orig","time","defi","role"),exact=TRUE)) {
if (length(vava) > 1) {
li <- set8listcomp(paste(vava,collapse=" "),li,ee[ii,]);
}
ve[ii] <- 0;
}
#
# dealing with the item
if (expr3present(nam,c("item"),exact=TRUE)) {
li$item <- form3norma(li$item);
ve[ii] <- 0;
}
# dealing with the link
if (expr3present(nam,c("link"),exact=TRUE)) {
if (length(vava) > 1) {
vava <- form3norma(vava," ",">",">");
vava <- form3decadre(vava);
li <- set8listcomp(vava,li,ee[ii,]);
}
ve[ii] <- 0;
}
}
#
if (any(ve>0)) {
nochecked <- ee[ve>0,,drop=FALSE];
# form3affiche(nochecked);
}
#
# getting the gn
gn <- list2gn(li);
# precautionary checking
if (g4n.mck) {check4valid(valid8gn(gn));}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
minbar8gn <- function(gn)
#TITLE finds the minimum number of arcs between nodes of a gn object
#DESCRIPTION
# Finds the minimum number of arcs between nodes of a gn object.
# To do so, the parentship is explored and a matrix is returned.
# This matrix is similar to the pam matrix but is richer. Its
# rows and columns are associated to each node. [i,j] is the minimum
# number of arcs to follow to go from node i to node j. When this
# is not possible, a value of -1 is introduced.
#DETAILS
# Own nodes are considered as zero distance children (in
# other words the diagonal of the resulting matrix is not
# -1 but 0).
#KEYWORDS utilities
#PKEYWORDS gn genealogy
#INPUTS
#{gn} <<The gn object to be investigated>>
#[INPUTS]
#VALUE
# a matrix (see DESCRIPTION field)
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# minbar8gn(g4n.gn7);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The transposed matrix has a similar interpretation
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_07
#REVISED 09_06_09
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
nbno <- nbnv(gn,gn@item);
noms <- gn2item(gn);
# particular cases
if (nbno < 2) {
return(matrix(0,nbno,nbno,dimnames=list(noms,noms)));
}
# initialization
res <- matrix(-1,nbno,nbno);
res <- res + diag(nbno);
dimnames(res) <- list(noms,noms);
# doing it
nbf <- 0; # nbr of arcs to obtain the child
nba <- 1; # nbr of added children during the loop
while (nba > 0) {
nbf <- nbf + 1; nba <- 0;
for (jbd in 1:nbno) {
enf <- which(res[jbd,] != -1); # children for nodes jbd
pos <- which(apply(outer(gn@arc@fle[,1],enf,"=="),1,sum)==1); # starting arcs
nenf <- gn@arc@fle[pos,2]; # possible new children
nenf <- setdiff(nenf,enf);# actual new children
if (length(nenf) > 0) {
nba <- nba + length(nenf);
res[jbd,nenf] <- nbf;
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
and4gn <- function(gn,names=1,pos=NULL)
#TITLE adds a series of nodes to a gn object
#DESCRIPTION
# This function adds a series of nodes to a /gn/
# without any links giving them the names into
# argument 'names'. They are unidimensional with
# empty variable names.
#DETAILS
# With respect to the internal order, the new nodes
# are introduced at the end.
#KEYWORDS
#PKEYWORDS gn nd
#INPUTS
#{gn}<<The object gn to be completed>>
#[INPUTS]
#{names} <<(=1) when numeric of length 1, it
# indicates the number of nodes to add
# (and the name will be automatically
# determined by form3names function.
# When character it is the vector
# of the new names and its length gives
# the number of node to add.>>
#{pos} <<(=NULL) gives the positions to add.
# When null, they will be automatically provided.
# When a matrix, it must comprise as many rows as
# new nodes and 2 (x,y) or 3 (x,y,z) columns.>>
#VALUE
# The completed object gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# and4gn(g4n.gn7,c("U","V","W"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_11_12
#REVISED 09_05_06
#--------------------------------------------
{
# checking and preparing
if (g4n.mck) {check4valid(valid8gn(gn));}
if (gn@item!="n") {
erreur(gn,"For the moment, adn4gn does not work when the slot item is not 'n'");
}
# about the new names
items <- gn2item(gn);
if (is.numeric(names)) {
check4tyle(names,"any",1,message="When numeric, names must be a single integer.");
names <- form3names(names,items);
}
if (!all(outer(items,names,"!="))) {
erreur(list(gn@nom,names),"Some names for new nodes already exists!");
}
nbnn <- length(names);
# about the new positions to give
if (!isvide(pos)) {
if (!is.matrix(pos)) {
erreur(pos,"When non null, 'pos' must be a matrix!");
}
if((nrow(pos) != nbnn) | !(ncol(pos) %in% c(2,3))) {
erreur(dim(pos),"When a matrix, pos must have 2 or 3 columns",
"and a number of rows identical to the number",
"of nodes to add");
}
}
###
### adapting the /gn/
#
# completing the nodes
for (nn in names) { gn@nom@x[[nn]] <- ""; }
#
# completing the arcs
gn@arc@nbn <- length(gn2item(gn,check=FALSE));
#
# completing the positions
if (is.null(pos)) {
angles <- (1:nbnn)*2*pi/nbnn;
xr <- range(gn@pos@posi[,1]);
yr <- range(gn@pos@posi[,2]);
cen <- c(mean(xr),mean(yr));
rad <- c(diff(xr),diff(yr))/2;
pos <- cbind(rad[1]*cos(angles),rad[2]*sin(angles)) +
outer(rep(1,nbnn),cen,"*");
}
if (ncol(pos == 2)) { pos <- cbind(pos,rep(0,nbnn),rep(0,nbnn));
} else { pos <- cbind(pos,rep(0,nbnn));}
gn@pos@posi <- rbind(gn@pos@posi,pos);
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
ends8gn <- function(gn)
#TITLE returns the root and leaf nodes/variables of a gn
#DESCRIPTION
# From a /gn/ object, the set of nodes/variables
# is partitioned in four classes:\cr
# (i) the root and leaf nodes/variables,\cr
# (ii) the root but not leaf nodes/variables,\cr
# (iii) the leaf but not root nodes/variables,\cr
# (iv) the remaining nodes/variables.\cr
# Of course, some of the classes can be empty.
#DETAILS No check about \code{gn}
#KEYWORDS
#PKEYWORDS bn gn
#INPUTS
#{gn}<<The gn.>>
#[INPUTS]
#VALUE
# a list of four named numeric vectors with the iin
# of the corresponding nodes/variables and the names as names.
# The four items are $RaL (root and leaf), $RwL (root
# but not leaf), $LwR (leaf but not root) and $rema (the
# remaining nodes/variables).
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# ends8gn(g4n.gn7);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_01
#REVISED 09_10_16
#--------------------------------------------
{
# determining the number of nodes/variables
nbn <- nbnv(gn,gn@item);
# preparing the resulting list
res <- vector("list",4);
names(res) <- c("RaL","RwL","LwR","rema");
for (i in 1:4) { res[[i]] <- numeric(0);}
# getting the parentship
pare <- neighbours8gn(gn,"parents");
chil <- neighbours8gn(gn,"children");
# filling the list
par <- chi <- numeric(nbn);
for (nn in bc(nbn)) {
par <- length(pare[[nn]]);
chi <- length(chil[[nn]]);
if (par == 0) {
if (chi == 0) {
res$RaL <- c(res$RaL,nn);
} else {
res$RwL <- c(res$RwL,nn);
}
} else {
if (chi == 0) {
res$LwR <- c(res$LwR,nn);
} else {
res$rema <- c(res$rema,nn);
}
}
}
# adding the names
nana <- gn2item(gn);
for (i in 1:4) { names(res[[i]]) <- nana[res[[i]]];}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
neighbours8gn <- function(gn,what="parents")
#TITLE returns the direct parents (or children) of a gn nodes
#DESCRIPTION
# Returns the parents/children of all nodes (or all variables
# according to \code{gn@item}) of 'gn'.
#DETAILS
# Parents means direct parents; children means direct children
#KEYWORDS
#PKEYWORDS genealogy
#INPUTS
#{gn}<<the gn object.>>
#[INPUTS]
#{what} << either \code{parents} or \code{children} accordingly.>>
#VALUE
# A list of character vectors containing the names of the parents,
# each component of the list is associate to an item (node or
# variable). When there is no parent, character(0) is returned.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# neighbours8gn(g4n.gn7,"parents");
# neighbours8gn(g4n.gn7,"children");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_16
#REVISED 09_10_16
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
if (!expr3present(what,c("parents","children"))) {
erreur(what,"'what' must be 'parents' or 'children'");
}
# getting the parents or children
nbn <- gn@arc@nbn;
if (nbn==0) { return(rbsb.lis0); }
res <- vector("list",nbn);
nnom <- gn2item(gn);
for (ii in bc(nbn)) { res[[ii]] <- character(0);}
for (ii in bc(nrow(gn@arc@fle))) {
chi <- gn@arc@fle[ii,2];
chn <- nnom[chi];
pai <- gn@arc@fle[ii,1];
pan <- nnom[pai];
#
if (expr3present(what,"parents")) {
res[[chi]] <- c(res[[chi]],pan);
} else {
res[[pai]] <- c(res[[pai]],chn);
}
}
# naming the result
names(res) <- nnom;
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
###########################################
########
#((((((( NEW S4 CLASS ion
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
cycle8pam <- function(pam)
#TITLE detects if a cycle exists from a pam matrix
#DESCRIPTION (ba)
# This function returns TRUE or FALSE if at least one cycle
# is detected within the graph defined by the pam matrix.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS pam cycle
#INPUTS
#{pam} <<The pam matrix>>
#[INPUTS]
#VALUE
# logical variable (TRUE: at least a cycle, FALSE : no cycle).
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# papa <- new("pam",rlt=matrix(c(0,0,1,1,0,0,0,1,0),3));
# cycle8pam(papa);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_10
#REVISED 07_10_19
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pam(pam));}
# initialization
nbn <- nrow(pam@rlt);
res <- numeric(0);
nbfait <- -1;
# starting the stupid loop
while (nbfait < length(res)) {
nbfait <- length(res);
for (jbd in bc(nbn)) {
papa <- which(pam@rlt[,jbd]==1);
if (length(unique(c(jbd,papa,res))) == (1+length(res))) {
res <- c(res,jbd);
}
}
}
if ((length(res)) != nbn) { res <- TRUE;
} else { res <- FALSE;}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
explore8pam <- function(pam,iir=bc(nrow(pam@rlt)),jjc=iir)
#TITLE finds different characteristics of relations
# between nodes
#DESCRIPTION (ba)
# exploring the parentship matrix 'pam', returns a list
# of different nodesxnodes matrices giving standard
# characteristics of the relationship between them.\cr
# The calculation is done with iin order
# and the result is proposed in iin order.
# The relation are:
# (i) the indication of the relation (-1=row is descendant,
# 0= none, 1= row is ascendant),
# (ii) the minimum number of arcs to join row and column
# (0 means no)
# (iii) the maximum number of arcs to join row and column
# (0 means no)
# (iv) the number of different paths joining row and column
#DETAILS
#KEYWORDS utilities
#PKEYWORDS bn gn
#INPUTS
#{pam} <<The pam object>>
#[INPUTS]
#{iir} << the subset of nodes to be considered
# as starting nodes. They will be en rows of the
# resulting matrices.>>
#{jjc} << the subset of nodes to be considered as ending
# nodes. They will be in columns of the resulting matrices.>>
#VALUE
# a list gathering two lists
# $des: a list of descriptions explaining what is
# computed in the differents matrices
# $rel: the list of the computed matrices
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# explore8pam(g4n.pam1);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# a former version of this function was called 'genea'
#FUTURE
# It could be more logical (and efficient when the number
# of nodes is important) that the matrices be replaced
# with couples of nodes...
#AUTHOR J.-B. Denis
#CREATED 07_06_17
#REVISED 09_05_10
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8pam(pam));}
pama <- pam@rlt; nbn <- nrow(pama);
if (!all(iir %in% 1:nbn)) {
erreur(iir,"is not acceptable for dim(pama) =",dim(pama));
}
if (!all(jjc %in% 1:nbn)) {
erreur(jjc,"is not acceptable for dim(pama) =",dim(pama));
}
if (length(unique(iir)) < length(iir)) {
erreur(iir,"repetitions are not accepted!");
}
if (length(unique(jjc)) < length(iir)) {
erreur(jjc,"repetitions are not accepted!");
}
# defining the objects
d1 <- new("des",orig="",time="",role="",
name="relation",
defi=paste("0 when no relation,",
"1 when the row is an ascendant of the column,",
"-1 when the row is a descendant of the column."));
d2 <- new("des",orig="",time="",role="",
name="minimum",
defi=paste("0 when no relation,",
"otherwise the minimum number of arcs between",
"the two nodes."));
d3 <- new("des",orig="",time="",role="",
name="maximum",
defi=paste("0 when no relation,",
"otherwise the maximum number of arcs between",
"the two nodes."));
d4 <- new("des",orig="",time="",role="",
name="number",
defi=paste("0 when no relation,",
"otherwise the number of different paths",
"following the arcs to go from one node",
"to the other."));
# finding the relationship matrices
pama <- pam@rlt;
pamb <- t(pama);
m1 <- pama - pamb;
m2 <- m3 <- m4 <- pama + pamb;
ka <- pama; kb <- pamb;
for (ii in (1+bc(nbn-2))) {
ka <- ka %*% pama; kb <- kb %*% pamb;
m1 <- m1 + ka - kb;
m2[(m2==0)&((ka>0)|(kb>0))] <- ii;
m3[ ((ka>0)|(kb>0))] <- ii;
m4 <- m4 + ka + kb;
}
nana <- list(iir,jjc);
m1 <- m1[iir,jjc,drop=FALSE]; dimnames(m1) <- nana;
m2 <- m2[iir,jjc,drop=FALSE]; dimnames(m2) <- nana;
m3 <- m3[iir,jjc,drop=FALSE]; dimnames(m3) <- nana;
m4 <- m4[iir,jjc,drop=FALSE]; dimnames(m4) <- nana;
list(des=list(d1,d2,d3,d4),
rel=list(m1,m2,m3,m4));
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
mindis8pam <- function(pam)
#TITLE finds the minimum distance between every pair of nodes
#DESCRIPTION (ba)
# From the parentship matrix, the minimum distance matrix between
# every pairs of nodes is computed. [i,j] means from node ith to node
# jth. In most cases (especially for non empty dags) the matrix is
# not symmetric.\cr
# The distance (not a mathematical distance) is the minimal number of
# arcs to follow before reaching the node j starting from the node i.
#DETAILS
# -1 are introduced on the diagonal.
#KEYWORDS utilities
#PKEYWORDS pam
#INPUTS
#{pam} <<The pam matrix to be investigated>>
#[INPUTS]
#VALUE
# The matrix containing the distances
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# mindis8pam(g4n.pam1);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The transposed matrix is also of value
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_24
#REVISED 07_11_07
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pam(pam));}
nbno <- nrow(pam@rlt);
mm <- res <- pam@rlt;
# going on
if (nbno > 2) { for (jbd in 2:(nbno-1)) {
mm <- mm %*% pam@rlt;
res[(res==0)&(mm>0)] <- jbd;
}}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
pos2pos <- function(pos)
#TITLE returns the equivalent pos object with standard view
#DESCRIPTION (ba)
# This function returns the equivalent pos object with standard view
# (i.e. view=c(0,0)). The central point of zoom is modified
# accordingly.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS plot pos
#INPUTS
#{pos} <<the pos object to be modified>>
#[INPUTS]
#VALUE
# The transformed pos object
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(pos2pos(g4n.pos0));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# At the beginning, pos2pos was called projection since it is
# the way to obtain the coordinates (in new (x,y)) for the
# representation.
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_25
#REVISED 07_11_12
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pos(pos));}
xyz <- rbind(pos@posi[,1:3],pos@zoom[1:3]);
for (jbd in bc(nrow(xyz))) {
uu <- xyz[jbd,];
vv <- geom3xyz2pol(uu);
vv[2:3] <- vv[2:3] + pos@view;
xyz[jbd,] <- geom3pol2xyz(vv);
}
if (nrow(xyz) > 1) { pos@posi[,1:3] <- xyz[-nrow(xyz),];}
pos@zoom[1:3] <- xyz[nrow(xyz),];
# returning
pos;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
pam2path <- function(pam,d,a)
#TITLE returns all paths between two nodes
#DESCRIPTION (ba)
# From the parentship matrix computes recursively
# all paths between two nodes.
#DETAILS
# The basic idea is quite simple. All paths
# between d (departure) and a (arrival) are the
# paths between every children of d and a, so
# a recursive procedure can be used.
#KEYWORDS utilities
#PKEYWORDS genealogy
#INPUTS
#{pam} <<pam object>>
#{d} <<departure node (internal number)>>
#{a} <<arrival node (internal number)>>
#[INPUTS]
#VALUE
# a list of vectors describing all possible paths
# going from d to a. The list is sorted according to
# the length of the path.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# pam2path(g4n.pam1,1,5);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_12
#REVISED 07_10_19
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pam(pam));}
# is the final node reached?
if (d == a) {
res <- list(d);
}
else {
# initialization
res <- vector("list",0);
# looking for the d children
ee <- which(1==pam@rlt[d,]);
# is there no child?
if (length(ee) == 0) {
res <- -1;
}
else {
# loop over all children from node d
for (jbd in ee) {
# computing the paths from this children
ff <- Recall(pam,jbd,a);
# is there a valid path?
if (is.list(ff)) {
# preparing a list with the right dimension
nres <- vector("list",length(res)+length(ff));
# copying the previous components
if (length(res)>0) { for (jd in 1:length(res)) {
nres[[jd]] <- res[[jd]];
}}
# adding the component with this child
if (length(ff)>0) { for (jd in 1:length(ff)) {
nres[[jd+length(res)]] <- c(d,ff[[jd]]);
}}
# storing to continue the loop
res <- nres;
}
else {
res <- -1;
}
}
}
}
# removing component -1 (means no path)
if (length(res) > 0) {
ko <- 0;
for (i in length(res)) {
if (identical(res[[i]],-1)) { ko <- 1+ko;}
}
if (ko > 0) {
uu <- vector("list",length(res)-ko);
ik <- 0;
for (i in length(res)) {
if (!identical(res[[i]],-1)) {
ik <- 1+ik;
uu[[ik]] <- res[[i]];
}
}
res <- uu;
}
}
# sorting the list
if (length(res) > 1) {
long <- rep(NA,length(res));
for (yd in 1:length(res)) { long[yd] <- length(res[[yd]]);}
res <- res[order(long)];
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
arc2pam <- function(arc)
#TITLE constructs the object pam from the object arc
#DESCRIPTION (ba)
# exploring the matrix arc@fle, returns a binary matrix with
# rows associated to each node giving their children.
# 0 means that this column is not a children as a pam object.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS genealogy arc pam
#INPUTS
#{arc} <<The arc object>>
#[INPUTS]
#VALUE
# the pam object
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(g4n.arc0);
# print(arc2pam(g4n.arc0));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_10
#REVISED 07_10_18
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8arc(arc));}
nbno <- arc@nbn;
res <- new("pam",rlt=matrix(0,nbno,nbno));
# doing it
for (jbd in bc(nrow(arc@fle))) {
res@rlt[arc@fle[jbd,1],arc@fle[jbd,2]] <- 1;
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
pam2arc <- function(pam)
#TITLE from the parentship object pam returns the arcs object
#DESCRIPTION (ba)
# from the parentship object pam returns the arcs object
#DETAILS
#KEYWORDS utilities
#PKEYWORDS genealogy arc pam
#INPUTS
#{pam} <<The object pam.>>
#[INPUTS]
#VALUE
# the arc object.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(pam2arc(g4n.pam0));
# print(pam2arc(g4n.pam1));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_18
#REVISED 09_10_20
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pam(pam));}
nbno <- nrow(pam@rlt);
res <- new("arc",nbn=nbno,fle=matrix(0,0,3));
# doing it
for (jbd in bc(nbno)) { for (jd in bc(nbno)) {
if (pam@rlt[jbd,jd] == 1) {
res@fle <- rbind(res@fle,c(jbd,jd,211));
}
}}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
geneal4pam <- function(pam,i,asc=TRUE)
#TITLE constructs the genealoty of a given node
#DESCRIPTION (ba)
# This function constructs the genealoty of a given node,
# that is returns the graph of all ascendants (descendants)
# starting from this node.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS genealogy
#INPUTS
#{pam} <<The pam matrix describing the parentship.>>
#{i} <<The considered node.>>
#[INPUTS]
#{asc} << must ascendants be looked for, if not
# the descendants.>>
#VALUE
# an arc object describing the obtained tree
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# geneal4pam(g4n.pam1,2);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_11_07
#REVISED 09_10_13
#--------------------------------------------
{
# starting
if (g4n.mck) {
check4valid(valid8pam(pam));
check4tyle(i,"numeric",1,message="Only one node at once");
}
nbn <- nrow(pam@rlt);
if ((i<1) | (i>nbn)) { erreur(NULL,"the node",i,"does not fit with the pam provided.");}
if (asc) { pam@rlt <- t(pam@rlt);}
res <- new("arc",nbn=nbn,fle=matrix(0,0,3));
# the included nodes
nin <- i;
# finding all involved nodes
ajout <- 1;
while (ajout > 0) {
ajout <- 0;
#cat("----------",ajout,"\n");
for (noe in nin) {
#cat("(((",nin,")))",noe,"\n");
pot <- which(pam@rlt[noe,] == 1);
#cat("|||",pot,"|||\n");
for (po in bf(pot)) {
p <- pot[po];
if (!(p %in% nin)) {
#cat("uuu\n");
nin <- c(nin,p);
ajout <- ajout+1;
}
}
}
}
# deducing the restricted graph
for (i in bf(nin)) {
ii <- nin[i];
for (j in bf(nin)) {
jj <- nin[j];
if (pam@rlt[ii,jj] == 1) {
res@fle <- rbind(res@fle,c(ii,jj,211));
}
}
}
if (asc) { res@fle[,1:2] <- res@fle[,c(2,1)];}
if (g4n.mck) {check4valid(valid8arc(res));}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
range8pos <- function(pos,padding=g4n.pgr0@padding)
#TITLE returns the ranges (x,y) for a pos
#DESCRIPTION (ba)
# This function returns the ranges (x,y) for a pos
# taking into account the zoom specification of the pos
# and the extreme values of its positions.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS geometry
#INPUTS
#{pos} <<The pos object.>>
#[INPUTS]
#{padding} <<The padding coefficient to apply.>>
#VALUE
# a list with two components \$x and \$y giving
# the ranges (min,max) of the two first positions
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# uu <- new("pos",posi=matrix(round(10*cos(1:20)),5));
# range8pos(uu);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_11_07
#REVISED 07_11_07
#--------------------------------------------
{
xra <- diff(range(pos@posi[,1]))/2;
yra <- diff(range(pos@posi[,2]))/2;
# computing the middle point of the nodes
xmi <- mean(range(pos@posi[,1]));
ymi <- mean(range(pos@posi[,2]));
# computing the range of the representation
xm <- xmi + xra*pos@zoom[1];
ym <- ymi + yra*pos@zoom[2];
xr <- xm + padding*c(-1,1)*xra/pos@zoom[4];
yr <- ym + padding*c(-1,1)*yra/pos@zoom[4];
list(x=xr,y=yr);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
new8arc <- function(nbno,nbar)
#TITLE creates an /arc/ with a specified number of nodes and arcs
#DESCRIPTION (ba)
# After checking that it is possible, returns an /arc/ object
# with the specified number of nodes (\code{nbno}) and arcs (\code{nbar}).
#DETAILS
#KEYWORDS misc
#PKEYWORDS arc
#INPUTS
#{nbno}<<Number of desired nodes.>>
#{nbar}<<Number of desired arcs.>>
#[INPUTS]
#VALUE
# A valid \code{arc} object. If not possible,
# a fatal error is issued
#EXAMPLE
# g4n3k("RESET"); # For R checking to be forgetten
# new8arc(10,5);
# \dontrun{new8arc(3,4);}
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_20
#REVISED 09_10_20
#--------------------------------------------
{
# checking
if (g4n.mck) {
check4tyle(nbno,"integer",1,message="nbno is the number of nodes");
check4tyle(nbar,"integer",1,message="nbar is the number of arcs");
if (nbno < 0) { erreur(nbno,"nbno is the number of nodes");}
if (nbar < 0) { erreur(nbar,"nbar is the number of arcs");}
if (nbar > nbno*(nbno-1)/2) {
erreur(list(nbno,nbar),"Too much arcs for the number of nodes");
}
}
#
# filling the @fle matrix
fle <- matrix(211,nbar,3);
nba <- 0;
for (dep in bc(nbno)) { for (arr in bc(nbno)) {
if (dep<arr) { if (nba < nbar) {
nba <- nba + 1;
fle[nba,1:2] <- c(dep,arr);
}}}}
# returning
new("arc",nbn=nbno,fle=fle);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Try the g4n package in your browser
Any scripts or data that you put into this service are public.
g4n documentation built on May 2, 2019, 5:47 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.
rbsb3k("reset");
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
g4n3k <- function(whi)
#TITLE assigns the constants for the g4n layer
#DESCRIPTION
# defines or returns the constants used within /rbsbgn/.
# The performed action depends on the argument.
#DETAILS
# All constant names start with 'g4n.'.
# This solution was adopted to replace
# a set of global constants that I had difficulty
# to make acceptable with R packages standards.
# It is recommended not to modify these constants
# unless you are completely aware of the consequences.\cr
# The constants can be any object type.
#PKEYWORDS helpful
#KEYWORDS misc
#INPUTS
#{whi} <<a character(1) indicating either to reset or
# to return the names or the current values. The possible
# values are \code{RESET}, \code{reset}, \code{names}, \code{definitions} or \code{values}.>>
# >>
#[INPUTS]
#VALUE
# When \code{whi=="RESET"} nothing (but the assignments are
# performed for all layers \code{rbsb} and \code{g4n}).
# When \code{whi=="reset"} nothing (but the assignments of
# the layer \code{g4n} are performed).
# When \code{whi=="names"} the names as a character vector.
# When \code{whi=="definitions"} the definitions as a named character vector.
# When \code{whi=="values"} the values through a named list.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(g4n.msi);
## to get the short labels
# g4n3k("names");
## to obtain the current values
# g4n3k("values");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_13
#REVISED 09_11_05
#--------------------------------------------
{
# checking
if (!(whi %in% c("RESET","reset","names","definitions","values"))) {
print.default(whi);
stop("g4n3k does not accept this argument");
}
#
if (whi=="RESET") { rbsb3k("RESET");}
#
# definition of the different constants
sc <- character(0);
sc["mck"] <- "Must systematic checks be done?";
sc["mwa"] <- "Must warning be simple warning?";
sc["msi"] <- "g4n signature";
sc["arc0"] <- "null /arc/";
sc["pam0"] <- "null /pam/";
sc["pam1"] <- "Example 1 of /pam/";
sc["pos0"] <- "current /pos/";
sc["pgr0"] <- "current /pgr/";
sc["gn0"] <- "null /gn/";
sc["gn1"] <- "Example 1 of /gn/";
sc["gn2"] <- "Example 2 of /gn/";
sc["gn3"] <- "Example 3 of /gn/";
sc["gn4"] <- "Example 4 of /gn/";
sc["gn5"] <- "Example 5 of /gn/";
sc["gn6"] <- "Example 6 of /gn/";
sc["gn7"] <- "Example 7 of /gn/";
#
# returning the names
#
if (whi=="names") { return(names(sc));}
#
# returning the definitions
#
if (whi=="definitions") { return(sc);}
#
# returning the values
#
if (whi=="values") {
res <- vector("list",0);
for (ii in bf(sc)) {
noco <- names(sc)[[ii]];
cat(noco,"\n");
eee <- paste("res[[\"",noco,"\"]] <- g4n.",noco,";",sep="");
eval(parse(text=eee));
}
return(res);
}
#
# loading the standard values
#
if (tolower(whi)=="reset") {
#
assign("g4n.mck", TRUE,pos=".GlobalEnv");
assign("g4n.mwa", TRUE,pos=".GlobalEnv");
assign("g4n.msi","/g4n/",pos=".GlobalEnv");
#
assign("g4n.arc0",new("arc",nbn=0,fle=matrix(NA,0,3)),pos=".GlobalEnv");
assign("g4n.pam0",new("pam",rlt=matrix(NA,0,0)),pos=".GlobalEnv");
assign("g4n.pam1",new("pam",rlt=matrix(c(rep(0,10),1,1,0,rep(c(0,0,0,0,1),2),1,0),5)),pos=".GlobalEnv");
assign("g4n.pos0",new("pos",
posi=matrix(NA,0,4),
view=c(0,0),
zoom=c(0,0,0,1)
),pos=".GlobalEnv");
assign("g4n.pgr0",new("pgr"),pos=".GlobalEnv");
#
assign("g4n.gn0",new("gn",
description=char2des("Null /gn/"),
nom=rbsb.nom0,
item="n",
pos=g4n.pos0,
arc=g4n.arc0,
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn1",new("gn",
description=char2des("Example 1 of /gn/"),
nom=rbsb.nom1,
item="n",
pos=new("pos",posi=matrix(c(1,2,1,1,2,2,0,0,0,2,1,1),3)),
arc=new("arc",nbn=3,fle=matrix(c(1,2,211),1)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn2",new("gn",
description=char2des("Example 2 of /gn/"),
nom=rbsb.nom2,
item="v",
pos=new("pos",posi=matrix(c(1,2,2,2,1,1,2,3,rep(0,4),rep(2,4)),4)),
arc=new("arc",nbn=4,fle=matrix(c(1,2,211),1)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn3",new("gn",
description=char2des("Example 3 of /gn/"),
nom=rbsb.nom3,
item="v",
pos=new("pos",posi=matrix(c(1,2,1,2,1,2,
1,1,2,2,3,3,
rep(0,6),rep(2,6)),6)),
arc=new("arc",nbn=6,fle=matrix(c(1,2,3,4,5,
2,3,4,5,6,
rep(211,5)),5)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn4",new("gn",
description=char2des("Example 4 of /gn/"),
nom=rbsb.nom4,
item="n",
pos=new("pos",posi=matrix(c(1,2,1,2,
rep(0,2),rep(2,2)),2)),
arc=new("arc",nbn=2,fle=matrix(c(1,2,
rep(211,1)),1)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn5",new("gn",
description=char2des("Example 5 of /gn/"),
nom=rbsb.nom5,
item="n",
pos=new("pos",posi=matrix(c(1,2,1,2,
rep(0,2),rep(2,2)),2)),
arc=new("arc",nbn=2,fle=matrix(c(1,2,
rep(211,1)),1)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn6",new("gn",
description=char2des("Example 6 of /gn/"),
nom=new("nom",x=cha2li(letters[1:6],nam=LETTERS[1:6])),
item="n",
pos=new("pos",posi=matrix(c(1,1,1,2,2,2,
1,2,3,1,2,3,
rep(0,6),rep(2,6)),6)),
arc=new("arc",nbn=6,fle=matrix(c(1,4,1,2,5,6,
rep(211,3)),3)),
pgr=g4n.pgr0),pos=.GlobalEnv);
assign("g4n.gn7",new("gn",
description=char2des("Example 7 of /gn/"),
nom=new("nom",x=cha2li(letters[1:10],nam=LETTERS[1:10])),
item="n",
pos=new("pos",posi=matrix(c(1,1,1,2,2,2,3,3,3,3,
1,2,3,1,2,3,1,2,3,4,
rep(0,10),rep(2,10)),10)),
arc=new("arc",nbn=10,fle=matrix(c(1,1,1,2,8,10,10,5,
2,5,4,3,6, 6, 9,6,
rep(211,8)),8)),
pgr=g4n.pgr0),pos=.GlobalEnv);
}
#
# Completing the series of null objects
rbsb.null <- c(rbsb.null,c("g4n.arc0","g4n.pam0","g4n.pgr0",
"g4n.pos0","g4n.gn0"));
assign("rbsb.null",rbsb.null,pos=.GlobalEnv);
#
# Completing the series of sets of constants
rbsb.pko <- c(rbsb.pko,"g4n");
assign("rbsb.pko",rbsb.pko,pos=.GlobalEnv);
#
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
parcours8gn <- function(gn,blocked=character(0),imon=TRUE)
#TITLE find the ascendances until blocking
#DESCRIPTION
# exploring the parentship, returns a matrix with
# rows associated to nodes giving their ancestors
# until (if possible) the first blocking node
#DETAILS
# In a first step the matrix of chidrenhood is
# calculated which can be expansive when the number
# of nodes is high.
#KEYWORDS
#PKEYWORDS gn genealogy
#INPUTS
#{gn} <<The gn object to be dealt>>
#[INPUTS]
#{blocked} <<(= character(0)) those nodes
# which are reference node for
# blocking>>
#{imon} <<(=TRUE) must blocked node be included?>>
#VALUE
# A square matrix. Its rows corresponds to every node.
# Its columns are associated to possible
# ascendants: 0 if not, 1 if it is. The node itself is not included
# that is the diagonal elements are zero. The row and column order are
# those of iin; the dimnames of this matrix are given by the node names.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# parcours8gn(g4n.gn7);
#REFERENCE
#SEE ALSO genea
#CALLING
#COMMENT
#FUTURE
# It could be more logical (and efficient when the number
# of nodes is important) that the value was a list of vectors
# and not a matrix which can be very sparse.
#AUTHOR J.-B. Denis
#CREATED 07_09_18
#REVISED 09_06_17
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
# initialization
nbno <- nbnv(gn,gn@item); par <- res <- matrix(0,nbno,nbno);
par <- t(arc2pam(gn@arc)@rlt);
if (gn@item=="n") {
moni <- nv2ion(blocked,gn@nom,"n",check=FALSE)@nk;
nnom <- nanv(gn@nom,"n");
} else {
moni <- nv2ion(blocked,gn@nom,"N",check=FALSE)@vk;
nnom <- nanv(gn@nom,"v");
}
# loop for every node
for (jbd in 1:nbno) { if (!is.element(jbd,moni)) {
qui <- numeric(0);
ppp <- which(par[,jbd]==1);
qui <- setdiff(union(qui,ppp),moni);
ajout <- 1;
if (length(qui) > 0) {while (length(ajout) > 0) {
ajout <- numeric(0);
for (jd in 1:length(qui)) {
pp <- which(par[,qui[jd]]==1);
ajout <- setdiff(union(ajout,pp),union(qui,moni));
}
qui <- union(qui,ajout);
}}
res[jbd,qui] <- 1;
}}
# including blocked nodes
if (imon) { for (jbd in 1:nbno) { if (!is.element(jbd,moni)) {
bord <- c(jbd,which(res[jbd,]==1));
if (length(bord) == 0) { erreur("from parcours8gn","Must comprise at least one node!");}
mm <- numeric(0);
for (jd in bord) {
mm <- union(mm,intersect(which(par[,jd]==1),moni));
}
res[jbd,mm] <- 1;
}}}
# returning
dimnames(res) <- list(nnom,nnom);
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
rmnd4gn <- function(gn,nk)
#TITLE removes a series of nodes from a gn object
#DESCRIPTION
# Removing the nodes and arcs associated to them,
# adjusting the slot arc consequently. Awaiting
# for the generalization of item in /gn/s, only
# node /gn/, i.e. gn@item='n' are accepted here.
#DETAILS
# the initial @nom slot is reduced.
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn}<</gn/ object to be modified.>>
#{nk} <<vector of number nodes to remove. Must be
# given in 'nk' form (see nv2ion).>>
#[INPUTS]
#VALUE
# The reduced object gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(rmnd4gn(g4n.gn1,1));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#????
# In fact there is another (also very interesting) way to remove a node; it
# consists not to remove node and associated arcs, but to transform the arcs
# of the parents and children nodes to keep the transmission (more precisely,
# indirect links can become direct ones). Must also be implemented.
#AUTHOR J.-B. Denis
#CREATED 07_09_06
#REVISED 09_10_20
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
# some preparation
if (is.character(nk)) {
nk <- nv2ion(nk,gn@nom,check=FALSE)@nk;
}
items <- gn2item(gn,check=FALSE);
nnrr <- nrow(gn@arc@fle);
if (nnrr > 0) {
aa <- matrix(items[gn@arc@fle[,1:2]],nnrr);
} else { aa <- matrix(NA,0,0);}
nk <- sort(unique(nk));
mk <- setdiff(bf(items),nk);
n2r <- items[nk];
n2k <- setdiff(items,n2r);
# removing the nodes in the slot nom
for (ii in bf(n2r)) {
gn@nom <- rmnd4nom(gn@nom,n2r[ii]);
}
# removing the corresponding positions
gn@pos@posi <- gn@pos@posi[mk,,drop=FALSE];
# removing the corresponding arcs under variable names
# to avoid a difficult permutation to apply
r2r <- numeric(0);
for (ii in bc(nrow(aa))) {
if (!(aa[ii,1] %in% n2k)) { r2r <- c(r2r,ii);}
if (!(aa[ii,2] %in% n2k)) { r2r <- c(r2r,ii);}
}
r2r <- unique(r2r);
r2k <- setdiff(bc(nrow(aa)),r2r);
# here the numbers must be renumbered
nou <- bf(items);
for (ii in bf(items)) {
nou[ii] <- ii - sum(nk < ii);
}
gn@arc@fle <- gn@arc@fle[r2k,,drop=FALSE];
gn@arc@fle[,1:2] <- nou[gn@arc@fle[,1:2]];
gn@arc@nbn <- length(n2k);
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
rmar4gn <- function(gn,ion)
#TITLE removes a series of arcs from a gn object
#DESCRIPTION
# Removing the arcs associated to a subset of nodes,
# but keeping the nodes (contrary to rmnd4gn)
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn}<<object gn defining the pruned graph>>
#{ion} <<vector of nodes the arc of which must be
# be removed, either the names or the
# internal identification.>>
#[INPUTS]
#VALUE
# The reduced object gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# uu <- g4n.gn1;
# print(uu@arc);
# print(rmar4gn(uu,"A")@arc);
#REFERENCE
#SEE ALSO rmnd4gn
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_17
#REVISED 09_06_17
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
# translating into numbers
if (gn@item=="n") {
qui <- nv2ion(ion,gn@nom,"n",check=FALSE)@nk;
} else {
qui <- nv2ion(ion,gn@nom,"N",check=FALSE)@vk;
}
# detecting the arcs to remove
iuq <- numeric(0);
# just removing the related arcs
if (length(qui > 0)) { for (ar in bc(nrow(gn@arc@fle))) {
afr <- gn@arc@fle[ar,1]; ato <- gn@arc@fle[ar,2];
if (is.element(afr,qui) | is.element(ato,qui)) {
iuq <- c(iuq,ar);
}
}}
if (length(iuq) > 0) { gn@arc@fle <- gn@arc@fle[-iuq,,drop=FALSE];}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
gn2item <- function(gn,check=FALSE)
#TITLE returns the item names of a /gn/ object
#DESCRIPTION
# (see slot @item of /gn/.)
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn} <<The gn object.>>
#[INPUTS]
#{check} <<Must checking be undertaken (conditionally
# to \code{g4n.mck}).>>
#VALUE
# a character providing the item names.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# gn2item(g4n.gn1);
# gn2item(g4n.gn2);
# gn2item(g4n.gn7);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
# This function has been produced for future
# evolutions of the /gn/ items. Not only
# nodes or variables as presently.
#AUTHOR J.-B. Denis
#CREATED 09_05_06
#REVISED 09_05_06
#--------------------------------------------
{
# checking
if (check) { if (g4n.mck) {check4valid(valid8gn(gn));}}
# creating
res <- nanv(gn,gn@item);
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
plot8cgn <- function(gn,xy)
#TITLE draws nodes and arcs of a gn with already computed xy values
#DESCRIPTION
# Internal drawing of plot.gn, isolated because it
# can be used for multiple plots. The plot is supposed
# to be already open and the coordinates of nodes already
# prepared. See plot8gn for the details about decorations.
#DETAILS
# The reason of xy besides the @pos of the gn object is to
# give the possibility of different projections with the
# same positions.
#KEYWORDS
#PKEYWORDS plot gn
#INPUTS
#{gn} <<The gn to plot>>
#{xy} <<Matrix of (x,y) (nbn x 2) coordinates for the nodes.>>
#[INPUTS]
#VALUE
# returns nothing but something is drawn on the open plot
#EXAMPLE
#REFERENCE
#SEE ALSO plot.gn
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_06_27
#REVISED 09_10_20
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
if (!all(dim(xy) == c(nbnv(gn,gn@item),2))) {
erreur(NULL,"xy not consistent in dimensions!");
}
# getting the node/variable names
nom <- gn2item(gn);
# ancillary function(s)
raccou <- function(x0,y0,x1,y1,di=gn@pgr@diar) {
c(geom3pointi(x0,y0,x1,y1,di),
geom3pointi(x1,y1,x0,y0,di));
}
nbno <- nbnv(gn,gn@item);
if (nbno < 2) {
erreur(nbno,"For this number of nodes no graph is issued",w=g4n.mwa);
return(invisible);
}
nbar <- nrow(gn@arc@fle);
# drawing the nodes
for (i in bc(nbno)) {
xx <- xy[i,1]; yy <- xy[i,2];
la <- nom[i]; de <- gn@pos@posi[i,4];
text(xx,yy,la,cex=gn@pgr@cexscale);
if (!is.na(de)) {
tail <- 6*gn@pgr@cexscale;
if (de == 1) { points(xx,yy,pch=22,cex=tail);}
if (de == 2) { points(xx,yy,pch=21,cex=tail);}
}
}
# drawing the arcs
for (i in bc(nbar)) {
n1 <- gn@arc@fle[i,1]; n2 <- gn@arc@fle[i,2];
ax <- raccou(xy[n1,1],xy[n1,2],
xy[n2,1],xy[n2,2]);
# style of the arcs
com <- gn@arc@fle[i,3];
# getting the heads, line type and width of the arrows
code <- com %/% 100; com <- com - 100*code;
code <- round(code); code <- min(max(code,0),3);
lty <- com %/% 10; com <- com - 10*lty;
lty <- round(lty); lty <- min(max(lty,0),6);
lwd <- com; lwd <- min(max(lwd,0.5),5);
arrows(ax[1],ax[2],ax[3],ax[4],
length=gn@pgr@arrowlength,
lwd=lwd,lty=lty,code=code);
}
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
cycles4gn <- function(gn)
#TITLE reduces the graph to the portion with cycles
#DESCRIPTION
# Just removing from the graph those nodes (and
# associated arcs) which cannot belong to a cycle
# because they are extreme (either without parent or
# without children).\cr
#DETAILS
#KEYWORDS
#PKEYWORDS gn genealogy
#INPUTS
#{gn}<<object gn defining the graph>>
#[INPUTS]
#VALUE
# The reduced object gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# cycles4gn(g4n.gn7); # returns the null /gn/
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The graph associated to a BN must reduce to nothing
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_06
#REVISED 07_09_07
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
rn <- 1;
# loop for removing the nodes
while ((rn > 0) & (nbnv(gn,gn@item) > 0)) {
rn <- 0;
nar <- nrow(gn@arc@fle);
nbd <- nbnv(gn,gn@item);
arc <- matrix(0,nbd,2);
if (nar > 0) { for (ar in 1:nar) {
arc[gn@arc@fle[ar,1],1] <- 1;
arc[gn@arc@fle[ar,2],2] <- 1;
}}
crit <- arc[,1]+arc[,2];
retire <- (1:nbd)[crit<2];
rn <- length(retire);
if (rn > 0) { gn <- rmnd4gn(gn,retire);}
}
# null case
if (nbnv(gn,gn@item)==0) { gn <- g4n.gn0;}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
path4gn <- function(gn,n1,n2,quel=1,elono=TRUE)
#TITLE reduces the graph to the portion in between two node sets
#DESCRIPTION
# Just removing from the graph those arcs (and nodes) which
# does not belong to a path going from a node to another one.\cr
# As graph comprising cycles can be introduced, both directions
# can be considered.
#DETAILS
# To get all descendants of n1, it suffices to put n2 as the complete
# set of nodes
#KEYWORDS
#PKEYWORDS gn genealogy
#INPUTS
#{gn} <<The object gn to consider.>>
#{n1} <<First node set to consider>>
#{n2} <<Second node set to consider>>
#[INPUTS]
#{quel} <<(=1) which directions to consider ?
# 1 for n1 to n2; 2 for n2 to n1 and 3
# for both directions>>
#{elono} <<(=TRUE) are eliminated other nodes ?>>
#VALUE
# The reduced object gn.
# Notice that if a node belongs to n1 (n2) but is not
# linked to any node of n2 (n1) it will be eliminated if elono is TRUE.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# path4gn(g4n.gn7,"E","J",3,FALSE);
# plot(path4gn(g4n.gn7,"A",LETTERS[1:10],3,FALSE));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The graph associated to a BN must not have path in both directions
# (because cycles are prohibited)
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_07
#REVISED 07_11_07
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
#
if (!is.element(quel,1:3)) { quel <- 1;}
if (gn@item=="n") {
n1 <- nv2ion(n1,gn@nom,"n",check=FALSE)@nk;
n2 <- nv2ion(n2,gn@nom,"n",check=FALSE)@nk;
} else {
n1 <- nv2ion(n1,gn@nom,"N",check=FALSE)@vk;
n2 <- nv2ion(n2,gn@nom,"N",check=FALSE)@vk;
}
# looking for lignee
if (length(n1)*length(n2) > 0) {
bah <- numeric(0);
lig <- minbar8gn(gn);
for (jbd in 1:2) {
if ((quel==jbd) | (quel == 3)) {
bas <- hau <- numeric(0);
if (jbd == 1) { pa <- n1; en <- n2;}
else { pa <- n2; en <- n1;}
for (i1 in pa) {
bas <- union(bas,which(lig[i1,] >= 0));
}
for (i2 in en) {
hau <- union(hau,which(lig[,i2] >= 0));
}
bah <- union(bah,intersect(bas,hau));
}}
if (elono) {
gn <- rmnd4gn(gn,setdiff(1:nbnv(gn,gn@item),bah));
}
else {
gn <- rmar4gn(gn,setdiff(1:nbnv(gn,gn@item),bah));
}
}
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
gn2path <- function(gn,d,a)
#TITLE returns all paths between two nodes
#DESCRIPTION
# To return all paths between two nodes, this function
# prepares the parentship matrix and calls
# the recursive function pam2path
#DETAILS
#KEYWORDS
#PKEYWORDS gn genealogy
#INPUTS
#{gn} <<a gn object>>
#{d} <<departure node (ion)>>
#{a} <<arrival node (ion)>>
#[INPUTS]
#VALUE
# a list of vectors with all possible paths
# (nodes are identified by iins)
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# gn2path(g4n.gn7,"A","F");
#REFERENCE
#SEE ALSO
#CALLING {pam2path}
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_17
#REVISED 09_06_17
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
# getting the node numbers
d <- nv2ion(d,gn@nom,"n",check=FALSE)@nk;
a <- nv2ion(a,gn@nom,"n",check=FALSE)@nk;
if ((length(d) != 1) | (length(a) != 1)) {
erreur(NULL,"Only ONE departure and ONE arrival nodes!");
}
# constructing the parentship matrix
mg <- arc2pam(gn@arc);
# calling pam2path and returning
pam2path(mg,d,a);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
pam2gn <- function(pam,description=rbsb.des0,
nom=rbsb.cha0)
#TITLE from a pam object generates a gn object
#DESCRIPTION
# From a pam object (parentship matrix) generates a gn object.
# Standard names can be provided for the nodes.
#DETAILS
#KEYWORDS
#PKEYWORDS gn genealogy pam
#INPUTS
#{pam} <<The pam obect>>
#[INPUTS]
#{description} <<(=rbsb.des0) description for the future gn>>
#{nom} <<(=rbsb.cha0) Names for the nodes>>
#VALUE
# a gn object
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# pam2gn(g4n.pam1);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_27
#REVISED 09_10_20
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8pam(pam));}
if (isvide(description)) {
description <-
new("des",name=paste("From",deparse(substitute(pam))));
}
nbno <- nrow(pam@rlt);
if (nbno == 0) {
res <- g4n.gn0;
} else {
if (length(nom) < nbno) { nom <- form3names(nbno);
} else { nom <- nom[1:nbno];}
res <- new("gn",description=description,
nom=char2nom(nom),
item="n",
arc=pam2arc(pam),
pos=new("pos",posi=matrix(0,nbno,4),
zoom=c(0,0,0,1),
view=c(0,0)),
pgr=g4n.pgr0);
res <- position4gn(res);
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
arc4gn <- function(gn,from,to,add=TRUE)
#TITLE adds or remove some arc(s) to or from a gn object
#DESCRIPTION
# Adds [removes] zero, one arc or a series of arcs to [from]
# a gn and returns the gn so modified. When arcs to add already
# exist, nothing is done. When arc to remove does not exist,
# nothing is done.
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn} <<The gn object>>
#{from} <<vector of ion describing the starting nodes of the arcs to add
# or remove. >>
#{to} <<vector of ion describing the ending nodes of the arcs to add
# or remove. >>
#[INPUTS]
#{add} <<(=TRUE) Adding? (or removing).>>
#VALUE
# The modified gn object.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# gn1 <- g4n.gn7;
# gn2 <- arc4gn(gn1,c("A","C"),c("E","E"));
# gg1 <- arc4gn(gn2,"A","B",FALSE);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_28
#REVISED 09_06_17
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
if (length(from) != length(to)) {
erreur(list(from,to),"'from' and 'to' must have equal lengths");
}
# getting a iin coding
if (gn@item=="n") {
ff <- nv2ion(from,gn@nom,"n",check=FALSE)@nk;
tt <- nv2ion(to ,gn@nom,"n",check=FALSE)@nk;
} else {
ff <- nv2ion(from,gn@nom,"N",check=FALSE)@vk;
tt <- nv2ion(to ,gn@nom,"N",check=FALSE)@vk;
}
# modifying the structure
pam <- arc2pam(gn@arc);
add <- add * 1;
for (fl in bf(from)) {
pam@rlt[ff[fl],tt[fl]] <- add;
}
gn@arc <- pam2arc(pam);
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
relation4gn <- function(gn,rel,cl="equal")
#TITLE formats the arc of a gn from a relation matrix
#DESCRIPTION
# From a completely described gn and a matrix of
# scores between all nodes of it, modifies the format
# of the arcs to take into account the strength of
# their relations.
#DETAILS
# (1) No arcs are added, only existing arcs are considered.\cr
# (2) The set of existing arcs is categorized into four
# classes : poor (dashed), small (continuous 1),
# medium (continuous 2) and strong (continuous 3).\cr
# (3) The classes are defined with three limits defined
# by cl. cl = 'equal' divides the arcs into approximately
# four equally numbered categories. cl = 'propto' divides the
# range of categories into four equal scaled categories.
# cl = numeric(3) imposed the three limit to use.\cr
# (4) NA valued arcs by rel are valued as the "minimum - 1"
# before determining the categories.
#KEYWORDS
#PKEYWORDS gn graph
#INPUTS
#{gn} <<The gn to be modified.>>
#{rel} <<The matrix of scores for the relationships. It is
# a non symmetric matrix, rows are considered parents
# of the columns.>>
#[INPUTS]
#{cl}<<(='equal') See the details section.>>
#VALUE The modified gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# g0 <- g4n.gn7;
# nbn <- nbnv(g0,g0@item);
# gg <- relation4gn(g0,matrix(1:nbn^2,nbn));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 08_10_16
#REVISED 08_10_16
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
if (!is.matrix(rel)) {
erreur(rel,"'rel' is expected to be a matrix.");
}
nbn <- nbnv(gn,gn@item);
if (!all(dim(rel) == c(nbn,nbn))) {
erreur(c(dim(rel),nbn),"Non compatible dimension for matrix rel.");
}
# extracting the fle matrix
fle <- gn@arc@fle;
# extracting the corresponding score values
kk <- fle[,1] + nbn*(fle[,2]-1);
sco <- rel[kk];
# replacing the missing values
if (sum(!is.na(sco)) == 0) {
erreur(rel,"All relations of use are NA!");
}
mii <- min(sco,n.rm=TRUE);
sco[is.na(sco)] <- mii - 1;
# preparing the class limitis
if (is.character(cl)) {
if (cl == "propto") {
ra <- range(cl);
cl <- seq(ra[1],ra[2],le=5)[-c(1,5)];
} else {
cl <- quantile(sco,seq(0,1,le=5)[-c(1,5)]);
}
} else {
if (!is.numeric(cl)) {
erreur(cl,"cl must be character or numeric.");
} else {
if (length(cl) == 3) {
cl <- sort(cl);
} else { erreur(cl,"cl must be of length 3");}
}
}
# modifying the format of the arcs
cla <- 1 + (sco > cl[1]) + (sco > cl[2]) + (sco > cl[3]);
lar <- 1 + (sco > cl[2]) + (sco > cl[3]);
typ <- 1 + (sco <= cl[1]);
gn@arc@fle[,3] <- 200 + 10*typ + lar;
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
list2gn <- function(li)
#TITLE transforms a consistent list into a new /gn/ 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 /gn/ object...
# The main use of this function is to generate /gn/ read from text files
# with the function \code{read8gn}.
#DETAILS
# When \code{$item} does not exist, \code{@item} is computed
# from \code{$posi} if it exists if not from \code{$arc}.
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{li} <<The list to be transformed into a /gn/ object.
# Compulosory component is \code{$name}.
# Usual component is \code{$arc}.
# Possible components are \code{$posi} for the positions,
# \code{$item} for the node/variable names.
#[INPUTS]
#VALUE
# The generated /gn/ object
#EXAMPLE
# g4n3k("RESET"); # for R checking need
# print(list2gn(list(name="a",item=c("A","B"))));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_06
#REVISED 10_06_17
#--------------------------------------------
{
# checking
if (g4n.mck) {
check4tyle(li,"list",-1,message="The first argument must be a list");
}
#
# getting the gn description
na <- li$name;
if (isvide(na)) { erreur(li,"$name is compulsory");}
des <- list2des(li);
# getting the /nom/ of the /gn/
if (!isvide(li$item)) {
itou <- li$item
} else {
if (!isvide(li$posi)) {
itou <- names(li$posi);
} else {
if (!isvide(li$arc)) {
itou <- li$arc;
itou <- paste(itou,collapse=">");
itou <- form3etsil(itou,OPA="",CPA="",
opa="",cpa="",sep=">");
itou <- sort(unique(itou));
} else {
itou <- rbsb.cha0;
}
}
}
nom <- char2nom(itou);
itou <- nanv(nom,0);
nbi <- length(itou);
#
# getting the type of the items
if (identical(nanv(nom,-1),itou)) {
item <- "n";
} else { item <- "v";}
#
# getting the arc slot
fle <- matrix(NA,0,2);
for (ll in bf(li$arc)) {
lu <-li$arc[ll];
lulu <- form3decadre(strsplit(lu,">",fixed=TRUE)[[1]]);
if (length(lulu) > 1) {
if (length(unique(c(lulu,itou)))!=length(itou)) {
erreur(list(itou,lulu),"Not all 'lulu' components are identified items");
}
nunu <- as.vector(outer(lulu,itou,"==") %*% bf(itou));
fle <- rbind(fle,cbind(nunu[-length(nunu)],nunu[-1]));
} else {
erreur(lulu,"This string does not indicate an arc... as expected");
}
}
if (nrow(fle)>0) { fle <- cbind(fle,211);
} else { fle <- matrix(NA,0,3);}
arc <- new("arc",nbn=nbi,fle=fle);
#
# introducing the positions
if (isvide(li$pos)) {
kmi <- 1; while(kmi*kmi < nbi) { kmi <- kmi+1;}
pos <- cbind(rep(1:3,3),rep(1:3,each=3))[sample(kmi*kmi,nbi,replace=FALSE),];
} else {
if ((length(unique(names(li$pos),itou)) > nbi) |
(length(li$pos) != nbi)) {
erreur(list(nom,names(li$pos)),"Bad correspondence between items and positions");
}
# including the proposed positions
nbco <- length(form3etsil(li$pos[[1]],
OPA="",CPA="",opa="",cpa="",
sep=" "));
pos <- matrix(NA,0,nbco);
for (pp in names(li$pos)) {
upp <- form3etsil(li$pos[[pp]],
OPA="",CPA="",opa="",cpa="",
sep=" ");
if (nbco != length(upp)) {
erreur(list(pp,li$pos),"The 'pp' component has got a different lenght that the other ones");
}
pos <- rbind(pos,upp);
}
}
if (any(is.na(as.numeric(pos)))) {
erreur(li$pos,"Not all values are numeric!");
}
pos <- matrix(as.numeric(pos),ncol=ncol(pos));
if (ncol(pos)<2) {
erreur(li$pos,"At least the two coordinates are expected");
}
if (ncol(pos)==2) { pos <- cbind(pos,0);}
if (ncol(pos)==3) { pos <- cbind(pos,2);}
pos <- new("pos",posi=pos);
# building it up
gn <- new("gn",description=des,nom=nom,item=item,
pos=pos,arc=arc,pgr=g4n.pgr0);
# checking the result
if (g4n.mck) {check4valid(valid8gn(gn));}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
gn2list <- function(gn)
#TITLE transforms a /gn/ object into a list
#DESCRIPTION
# Just translating all slot of the /gn/ into
# associated components of a list.
# This is the reverse function of \code{list2gn}.
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn} <<The /gn/ to be transformed into a list.>>
#[INPUTS]
#VALUE
# The generated list
#EXAMPLE
# g4n3k("RESET"); # For R checking compliance
# gn2list(g4n.gn3);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_06_22
#REVISED 10_06_22
#--------------------------------------------
{
# some checks
if (g4n.mck) {
che <- valid8gn(gn);
if (!identical(che,TRUE)) {
erreur(che,"/gn/ is not valid");
}
}
#
# initializing the list
res <- vector("list",0);
#
# getting the gn description
for (dd in slotNames("des")) {
res[[dd]] <- slot(gn@description,dd);
}
#
# getting the items
if (gn@item=="n") {
nbit <- nbnv(gn,"n");
item <- nv2ion(0,gn@nom,"n")@nn;
} else {
nbit <- nbnv(gn,"v");
item <- nv2ion(0,gn@nom,"v")@nvn;
}
res$item <- item;
#
# getting the arcs
res$arc <- rbsb.cha0;
for (aa in bc(nrow(gn@arc@fle))) {
iaa <- gn@arc@fle[aa,1:2];
res$arc <- c(res$arc,paste(item[iaa[1]],">",
item[iaa[2]],sep=""));
}
#
# getting the positions
res$pos <- vector("list",0);
for (pp in bc(nbit)) {
res$pos[[item[pp]]] <- paste(gn@pos@posi[pp,],collapse=" ");
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
write8gn <- function(gn,fi=rbsb.fou,ap=FALSE)
#TITLE writes a /gn/ to file
#DESCRIPTION
# writes a /gn/ objects to a file to be
# readable with \code{read8gn}
#DETAILS
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{gn} <<The /gn/ to be written.>>
#[INPUTS]
#{fi} <<name of the file to be written.
# When \code{rbsb.cha0} no file is
# written but a charecter is returned.>>
#{ap} <<Must an existing file be appended?>>
#VALUE
# nothing but a file is created or modified
#EXAMPLE
# g4n3k("RESET"); # For R checking compliance
# write8gn(g4n.gn3);
# readLines(rbsb.fou);
# unlink(rbsb.fou);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 10_06_22
#REVISED 10_06_30
#--------------------------------------------
{
# some checks
if (g4n.mck) {
che <- valid8gn(gn);
if (!identical(che,TRUE)) {
erreur(che,"/gn/ is not valid");
}
}
#
# creating the list
lili <- gn2list(gn);
#
# adapting the list for a standard use of list2file
#
# writing the file and returning
list2file(lili,fi,
tags=rbsb.tag2,
ap=ap);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
position4gn <- function(gn,heur="a")
#TITLE proposes positions for the nodes of a gn object
#DESCRIPTION
# Following some heuristics computes new positions for a /gn/
#DETAILS
#KEYWORDS
#PKEYWORDS gn plot
#INPUTS
#{gn} <<gn object>>
#[INPUTS]
#{heur} <<(='a') indicates which heuristic must be used.
# (a) for acp on the arc,
# (h) adapted for hierarchical trees from roots,
# (h2) idem but with vertical alternance,
# (H) adapted for hierarchical trees from leafs,
# (H2) idem but with vertical alternance.
#VALUE
# The same 'gn' object with the new positions
#REFERENCE
#FUTURE
# Ideas for more heuristics
#{*} <<add two other axes>>
#{*} <<Random>>
#{*} <<on a lattice with some heuristic>>
#{*} <<on concentric circles around a given node,
# possibly chosen for its properties>>
#{*} <<take into account the direction of arcs>>
#SEE ALSO
#CALLING
#COMMENT
# The algorithm does not seem very effective! Think about other ideas.
#AUTHOR J.-B. Denis
#CREATED 07_05_22
#REVISED 09_10_16
#--------------------------------------------
{
# some checks
if (g4n.mck) {check4valid(valid8gn(gn));}
heurp <- c("a","h","h2","H","H2");
if (sum(heur==heurp)!=1) {
erreur(list(heur,heurp),"argument 'heur' took an inexpected value");
}
# constructing the relationship matrix
eps <- 0.00001;
np <- nbnv(gn,gn@item);
if (np <= 0) {return(gn);}
if (heur=="a") {
fleches <- gn@arc@fle;
if (nrow(fleches) > 0) {
rrr <- matrix(0,np,np);
for (i in 1:np) { rrr[i,i] <- 2;}
for (i in 1:nrow(fleches)) { rrr[fleches[i,1],fleches[i,2]] <- 1;}
rrr <- rrr + t(rrr) + eps;
# deducing a distance matrix
rrr <- 1/rrr - 1/max(rrr);
# centring the distance matrix
uu <- apply(rrr,1,mean);
nn <- rep(1,np);
rrr <- rrr - outer(uu,nn) - outer(nn,uu) + mean(rrr);
# finding its first singular vector
vv <- svd(rrr)$u[,1];
# deducing the order
oo <- order(vv);
}
else { # no arc
oo <- 1:np;
}
# computing the new positions
theta <- (1:np)*2*pi/np;
theta <- theta[oo];
gn@pos@posi <- cbind(cos(theta),sin(theta),0,0);
gn@pos@zoom <- c(0,0,0,1);
gn@pos@view <- rep(0,2);
}
#
if (heur%in% c("h","h2","H","H2")) {
root <- expr3present("h",heur);
altv <- expr3present("2",heur);
if (cycle8pam(gn@pam)) {
erreur(gn,paste("This graph has got cycle(s), use another heurisitics that",heur));
}
ax <- function(x) { if(diff(range(x))>0) {(x-min(x))/(max(x)-min(x));}else{0.5;}}
# finding the roots
nbn <- nbnv(gn,gn@item);
nopla <- ends8gn(gn);
roots <- c(nopla$RwL,nopla$RaL);
leaves <- c(nopla$LwR,nopla$RaL);
if (length(roots) == 0) {
rapport("No root for this gn but no cycles were previously detected?");
}
if (length(leaves) == 0) {
rapport("No leave for this gn but no cycles were previously detected?");
}
# finding the minimum distance to the roots or leaves as ordinates
dd <- minbar8gn(gn);
dd[dd<=0] <- max(dd);
X <- Y <- rep(NA,nbn);
Y[roots] <- 0;
for (ii in bc(nbn)) { if (is.na(Y[ii])) {
Y[ii] <- min(dd[roots,ii]);
}}
# scoring successively the abscissae
X[roots] <- ax(bf(roots));
nbe <- max(Y);
for (ii in bc(nbe)) { if (length(Y==ii)>0) {
qq <- which(Y==ii);
rr <- rep(0,length(qq));
for (jj in bf(qq)) {
jjj <- qq[jj];
for (kk in bc(nbn)) { if (!is.na(X[kk])) {
rr[jj] <- rr[jj] + X[kk]*(dd[kk,jjj]==ii);
}}
}
X[qq] <- ax(rr);
}}
if (!root) {
# modifying the ordinates accordingly
Y <- NA;
Y[leaves] <- 0;
for (ii in bc(nbn)) { if (is.na(Y[ii])) {
Y[ii] <- min(dd[ii,leaves]);
}}
}
if (altv) {
# alternating vertically
ry <- range(Y);
for (y in ry[1]:ry[2]) {
sel <- which(Y==y);
if (length(sel) > 1) {
qui <- sel[(rank(X[sel]) %% 2) == 0];
Y[qui] <- Y[qui]+0.25;
}
}
}
# constructing the gn
gn@pos@posi <- cbind(X,Y,0,0);
gn@pos@zoom <- c(0,0,0,1);
gn@pos@view <- rep(0,2);
}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
plot3D8gn <- function(gn,...)
#TITLE plots an object gn according to its 3 dimensions
#DESCRIPTION
# The figure is divided into 4 quadrants, 3 of them are used to
# draw the graph according to its (X,Y), (X,Z) and (Z,Y) coordinates
#DETAILS
#KEYWORDS
#PKEYWORDS plot gn
#INPUTS
#{gn} <<the gn to plot>>
#[INPUTS]
#{...} <<to give when first calling to the standard plot function>>
#VALUE
# returns nothing but a plot is drawn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# plot3D8gn(g4n.gn7);
#REFERENCE
#SEE ALSO
#CALLING {plot8cgn}
#COMMENT
#FUTURE
# In the last quadrant, plots the ACP with the first two axis derived
# from the pseudo-distance given by mindis8pam (or pam matrix)...
#AUTHOR J.-B. Denis
#CREATED 07_07_17
#REVISED 07_11_07
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
# preparing the plots
nbno <- length(gn@nom);
mm <- 0.1; ra <- rep(NA,3);
for (i in 1:3) { ra[i] <- diff(range(gn@pos@posi[,i])); }
ma <- mm*ra;
mi <- ra[3]+2*ma[3];
xr <- c(0,ra[1]+2*ma[1]+mi);
yr <- c(0,ra[2]+2*ma[2]+mi);
plot(0,0,xlim=xr,ylim=yr,type="n",
axes=FALSE,xlab="",ylab="",...);
# axis
text(xr[2],mi,"X",cex=3);
text(mi,yr[2],"Y",cex=3);
text(xr[1],mi,"Z",cex=3);
text(mi,yr[1],"Z",cex=3);
abline(h=mi);abline(v=mi);
# last quadrant
xgr <- mi/2; ygr <- mi/2;
tgr <- paste(nbno,"nodes and",nrow(gn@arc@fle),"arcs");
text(xgr,ygr,tgr);
# drawing nodes and arcs (X,Y)
gd <- gn;
calage <- c(mi+ma[1]-min(gd@pos@posi[,1]),
mi+ma[2]-min(gd@pos@posi[,2]));
xy <- gn@pos@posi[,1:2] +
matrix(calage,nbno,2,byrow=TRUE);
plot8cgn(gd,xy);
# drawing nodes and arcs (X,Z)
gd <- gn;
calage <- c(mi+ma[1]-min(gd@pos@posi[,1]),
ma[3]-min(gn@pos@posi[,3]));
xy <- gn@pos@posi[,c(1,3)] +
matrix(calage,nbno,2,byrow=TRUE);
plot8cgn(gd,xy);
# drawing nodes and arcs (Z,Y)
gd <- gn;
calage <- c(ma[3]-min(gd@pos@posi[,3]),
mi+ma[2]-min(gd@pos@posi[,2]));
xy <- gn@pos@posi[,c(3,2)] +
matrix(calage,nbno,2,byrow=TRUE);
plot8cgn(gd,xy);
invisible();
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
rgn <- function(des,type="hier",
nno=c(5,10),nar=c(10,20),
nom=LETTERS,dire="nat",lev=1)
#TITLE creates a pseudo-random gn object
#DESCRIPTION
# Creates a gn object which characteristics are
# randomly generated following the requirements of the call.
# Also positions illuminating the struture are proposed.
# Normally the produced gn is connected and without cycles.
# When the request is not possible, a warning is issued and
# some compatible option is provided. Using this function with
# the same set.seed starting point (and the same request) must
# produce identical gn.\cr
# Different types of gn are possible, their characteristics
# are given by arguments and pseudo-randomness. The type argument
# describes the structure of the links without care about the
# directions (as edges). The possible types are:\cr
#{chain} <<All nodes are aligned in a simple chain. So a relationship
# exists between nno and nar: nno = nar +1. Then nno will
# be drawn and nar deduced.>>
#{ring} <<Like the chain type but a cycle is done with the
# relationships and nno = nar.>>
#{hier} <<A hierarchy in the sense that the nodes can be disposed in
# a dendrogram structure; a particular case of this is the "star"
# structure when there only a branching point and the branches can
# comprise several nodes.>>
#{audit} <<A hierarchy with two levels. For this specific case, 'nno' is
# the number of grouping levels and 'nar' is the number of
# terminal nodes for each grouping levels. Names of nodes are
# determined accordingly.>>
#{square} <<Not so simple to describe. Nodes are placed in the cell of
# square matrix and edges between nodes respects this structure.
# Arcs (including their number) are deduced from the node
# positions. Run some cases and you will understand seing the
# plot.>>
#{tetra} <<Four of the nodes are on the vertices of a tetrahedron and the
# other nodes are on its edges.>>
#{total} <<The maximum number of arcs, nno*(nno-1)/2, is provided.
# So nar will not be considered.>>
# It is suggested that the seed be initialized before calling this function.
#DETAILS
# Of course if too much arcs are ordered, the probability of a
# non-cycle graph may be very small, even null.\cr
# To prevent this, a local nb_trial limits the number of draws,
# if this limit is reached then a fatal error is issued.\cr
# For some type (e.g. "square"), the ordered number of arcs and nodes
# may not be respected for some reasons.
#KEYWORDS
#PKEYWORDS gn
#INPUTS
#{des} <<Either the name or the description (preferably) for the
# newly created gn.>>
#[INPUTS]
#{type} <<type of the gn, see the description field for details>>
#{nno} << range within which must be the number of nodes. Of course
# the range can be null, in that case the number of nodes is directly
# provided by the user. If not, it is drawn according to a uniform
# distribution (one integer from \code{nno[1]} to \code{nno[2]}).\cr
# Single values are repeated, e.g \code{5} becomes \code{c(5,5)}.
# When audit, it gives the number of grouping nodes.>>
#{nar} << range within which must be the number of arcs. Similar
# to \code{nno} but \code{nno} being fixed \code{nar} must satisfy some constraints. These
# constraints may also depend on the \code{type} of /gn/.\cr
# When audit, it gives the number of nodes for each grouping nodes.\cr
# Single values are repeated, e.g \code{5} becomes \code{c(5,5)}.>>
#{nom} <<vector of names to be used for the nodes.>>
#{dire} << indicates the directions of the arcs between the
# nodes of a /gn/. There are two possibilities: "nat" for natural
# directions and "ran" for random under the restriction of no
# cycles.\cr
# For 'audit' the two choices are 'nat' for putting the first node
# as root else it will be the synthesis.\cr
# No effect when type ="ring".>>
#{lev} << maximum level of hierarchy; only used when \code{type} is "hier".>>
#VALUE
#EXAMPLE
# set.seed(1234);
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# r1 <- rgn(char2des("r1"),type="hier");
# r2 <- rgn(char2des("r2"),type="square");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
# It is good to have only ONE rgn function, so that this one
# can generate a large variety of gns. Nevertheless, it is not
# that easy that the same collection of argument can apply to
# every one. An idea for the future could be to have only three
# arguments : des, type and argu where argu is a list where the
# components might be different according to the type.
#AUTHOR J.-B. Denis
#CREATED 07_10_08
#REVISED 10_06_09
#--------------------------------------------
{
# some precautions
nno <- round(range(nno)); nar <- round(range(nar));
if (min(c(nno,nar)) < 1) {
erreur(list(nno,nar),"At least one node and one arc are necessary!");
}
#
if (type=="audit") {
# a new type differently based
## determining the number of grouping nodes
if (nno[1]==nno[2]) {nbgn <- nno[1];
} else { nbgn <- sample(nno[1]:nno[2],1);}
## determining the number of nodes within each
if (nar[1]==nar[2]) { nbno <- rep(nar[1],nbgn);
} else {
nbno <- sample(nar[1]:nar[2],nbgn,replace=TRUE);
}
## determining the names of the nodes
nbn <- 1+nbgn+sum(nbno);
if (length(nom) >= nbn) { noms <- nom[1:nbn];
} else {
noms <- rep(NA,nbn);
if (dire=="nat") { noms[1] <- "<<SYNTH>>";
} else { noms[1] <- "<<ROOT>>";}
noms[1+1:nbgn] <- form3names(nbgn);
KK <- 1+nbgn;
for (i in 1:nbgn) {
noms[KK+1:nbno[i]] <- paste(noms[1+i],"(",1:nbno[i],")",sep="");
KK <- KK + nbno[i];
}
noms[1+1:nbgn] <- paste("<",noms[1+1:nbgn],">",sep="");
}
## determining the positions
posi <- matrix(0,nbn,4);
posi[1,1] <- 1;
posi[1+1:nbgn,2] <- -1;
posi[1+1:nbgn,1] <- (-1/2 + (1:nbgn))*2/nbgn;
posi[-c(1:(nbgn+1)),2] <- -2;
posi[-c(1:(nbgn+1)),1] <- (-1/2 + (1:sum(nbno)))*2/sum(nbno);
## determining the arcs for this gn
nbar <- nbn-1;
mar <- new8arc(nbn,nbar);
mar@fle[1:nbgn,1:2] <- c(rep(1,nbgn),1+1:nbgn);
KK <- nbgn;
for (i in 1:nbgn) {
mar@fle[KK+1:nbno[i],1] <- rep(1+i,nbno[i]);
mar@fle[KK+1:nbno[i],2] <- 1+KK + (1:nbno[i]);
KK <- KK + nbno[i];
}
if (dire == "nat") {
uu <- mar@fle[,1];
mar@fle[,1] <- mar@fle[,2];
mar@fle[,2] <- uu;
}
pos <- new("pos",posi=posi,zoom=c(0,0,0,1),view=c(0,0));
## returning
gg <- new("gn",
description=char2des(des),
nom=char2nom(noms),
item="n",
arc=mar,
pos=pos,
pgr=g4n.pgr0);
return(gg);
}
# trying to avoid cycles
nb_trial <- 1000;
# numbers of nodes and arcs
if (nno[1] == nno[2]) { nbno <- nno[1];
} else { nbno <- sample(nno[1]:nno[2],1);}
if (type %in% c("chain","hier")) { nbar <- nbno - 1;
} else {
if (type == "ring") { nbar <- nbno;
} else {
if (type == "total") { nbar <- nbno*(nbno-1)/2;
} else {
if (nar[1] == nar[2]) { nbar <- nar[1];
} else { nbar <- sample(nar[1]:nar[2],1);}
}
}
}
# names for the nodes
if (length(nom) < nbno) { nom <- form3names(nbno);
} else { nom <- nom[1:nbno];}
# the different types
ltype <- c("chain","ring","hier","square","tetra","total","audit");
if (!(type %in% ltype)) {
cat("You ask a gn of type",type,"but this type is not yet implemented\n");
cat("Available type are:",ltype,"\n");
erreur(NULL,"type not available!");
}
if (nbar > nbno*(nbno-1)/2) {
nbar <- nbno*(nbno-1)/2 - 1;
}
mar <- new8arc(nbno,nbar);
posi <- matrix(0,nbno,4);
lim <- matrix(NA,2,3);
vie <- rep(0,2);
if (type == "chain") {
for(jbd in 1:nbar) {
if (dire == "nat") { fle <- c(jbd,jbd+1);
} else { fle <- sample( c(jbd,jbd+1),2);}
mar@fle[jbd,1:2] <- fle;
}
pp <- arc2pam(mar);
for(jbd in 1:nbno) {
uu <- sum(pp@rlt[jbd,]) - sum(pp@rlt[,jbd]);
posi[jbd,1:3] <- c(jbd,uu,0);
}
}
if (type == "ring") {
mar@fle[nbar,1:2] <- sample(c(nbar,1));
for(jbd in 1:(nbar-1)) {
mar@fle[jbd,1:2] <- sample( c(jbd,jbd+1),2);
}
if(cycle8pam(arc2pam(mar))) { mar@fle[1,1:2] <- mar@fle[1,c(2,1)];}
for(jbd in 1:nbno) {posi[jbd,1:3] <- c(cos(2*pi/nbno*jbd),
sin(2*pi/nbno*jbd),0);}
}
if (type == "hier") {
# parentship
enf <- rep(0,nbno); niv <- rep(NA,nbno); names(niv) <- nom;
enf[1] <- niv[1] <- 0; nbf <- 1;
for (jbd in 2:nbno) { while(is.na(niv[jbd])) {
jd <- sample(which(!is.na(niv)),1);
if ((niv[jd] <= lev) | (enf[jd] == 0)) {
niv[jbd] <- niv[jd] + 1;
enf[jd] <- enf[jd] + 1;
mar@fle[jbd-1,1:2] <- c(jd,jbd);
}
}}
# positions
mmm <- arc2pam(mar);
xx <- yy <- rg <- rep(NA,nbno); names(rg) <- nom;
mlev <- max(niv);
xx[1] <- yy[1] <- 0; rg[1] <- 1;
for (jbd in 1:mlev) {
# dealing with level jbd
qui <- which(niv == jbd);
val <- rep(0,length(qui));
for (jd in bf(qui)) {
che <- pam2path(mmm,1,qui[jd])[[1]];
ch <- che[-length(che)];
for (sd in 1:length(ch)) {
qq <- ch[sd];
val[jd] <- val[jd] + rg[qq]*nbno^(mlev-niv[qq]);
}
}
rg[qui] <- rank(val,ties.method="random");
xx[qui] <- rg[qui] - mean(rg[qui]);
yy[qui] <- -jbd;
}
posi <- cbind(xx,yy,rep(0,nbno),rep(0,nbno));
# randomness
if (dire == "ran") {
for (jbd in 1:nrow(mar@fle)) {
mar@fle[jbd,1:2] <- sample(mar@fle[jbd,1:2],2);
}
}
}
if (type == "square") {
# square size
k <- ceiling(sqrt(nbno));
# ensuring connectedness
ppo <- matrix(0,k,k);
ppo[1,] <- 1:k; ppo[2:k,1] <- (k+1):(2*k-1);
ppo <- ppo[sample(k),sample(k)];
# positionning the remaining nodes
for (jbd in bc(nbno-2*k+1)) {
jd <- jbd + 2*k - 1;
uu <- sample(nbno - jd + 1,1);
vv <- which(ppo == 0)[uu];
ppo[vv] <- jd;
}
# defining arcs and positions
mar <- new8arc(nbno,0);
for (i in bc(k)) { for (j in bc(k)) { if (ppo[i,j] > 0) {
# by column
if (i < k) {
uu <- ppo[(i+1):k,j];
if (sum(uu) > 0) {
qq <- which(uu > 0)[1];
mar@fle <- rbind(mar@fle,c(uu[qq],ppo[i,j],211));
}
}
# by row
if (j < k) {
uu <- ppo[i,(j+1):k];
if (sum(uu) > 0) {
qq <- which(uu > 0)[1];
mar@fle <- rbind(mar@fle,c(uu[qq],ppo[i,j],211));
}
}
posi[ppo[i,j],1:3] <- c(k-j,i,0);
}}}
# randomness
if (dire == "ran") {
for (jbd in 1:nrow(mar@fle)) {
mar@fle[jbd,1:2] <- sample(mar@fle[jbd,1:2],2);
}
ppa <- arc2pam(mar);
nbt <- 1;
while(cycle8pam(ppa)) {
if (nbt > nb_trial) {
erreur(NULL,"Seems difficult not to get cycles!");
}
nbt <- nbt + 1;
for (jbd in 1:nrow(mar@fle)) {
mar@fle[jbd,1:2] <- sample(mar@fle[jbd,1:2],2);
}
ppa <- arc2pam(mar);
}
}
}
if (type == "tetra") {
erreur(type,"to be done");
}
if (type == "total") {
kk <- 0;
for (jbd in 1:(nbno-1)) { for (jd in (jbd+1):nbno) {
kk <- kk+1;
mar@fle[kk,1:2] <- c(jbd,jd);
}}
for(jbd in 1:nbno) {posi[jbd,1:3] <- c(cos(2*pi/nbno*jbd),
sin(2*pi/nbno*jbd),0);}
}
# returning
pos <- new("pos",posi=posi,zoom=c(0,0,0,1),view=c(0,0));
#
gg <- new("gn",
description=char2des(des),
nom=char2nom(nom),
item="n",
arc=mar,
pos=pos,
pgr=g4n.pgr0);
gg;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
modify4gn <- function(gn)
#TITLE interactive modifications of a gn
#DESCRIPTION
# graphical interface to modify (i) the positions,
# (ii) the arcs and (iii) the nodes of an object of class gn.
# Besides, it provides the facility to change the viewpoint
# from which is drawn the graph (positions of a gn object
# are defined in R to the 3).
# \cr The modified gn is returned.
#\cr
# To exit, just click the grey button 'E'
#\cr
# Action are started by the left hand buttons. Their codes are:\cr
# "rst" for resetting (cancel all modifications),\cr
# "MN" for moving the position of a node (the user must click
# twice: for indicating the node and then the new desired
# position),\cr
# "AA" for adding an arc (the user must click twice to indicate the
# starting node then the ending node), \cr
# "RA" for removing an existing arc (the user must click twice to
# indicate the arc to be removed), \cr
# "AN" for adding a node (the user must click once to indicate the
# position of the new node), its name is automatically provided
# but can be changed afterwards, \cr
# "RN" for removing a node (the user must click once, on the node
# to be removed), \cr
# "+" for narrowing the zoom (the user must click once, on the point
# where the zoom must be centered; the zooming coefficient is
# driven by the @pgr@kzoom parameter),\cr
# "-" for widing the zoom (the user must click once, on the point
# where the zoom must be centered; the zooming coefficient is
# driven by the @pgr@kzoom parameter),\cr
# "Rot" for rotating the representation in R to the three (the
# user must click once, in the direction of the rotation and more or less
# close to the center to indicate the angle to perform; the two big
# circles which appears on the diagram are associated to rotations of
# 5 and 10 degrees.
#DETAILS
#KEYWORDS
#PKEYWORDS plot gn
#INPUTS
#{gn} <<the gn object gn to be interactively modifyed.>>
#[INPUTS]
#VALUE
# The modified gn by the actions performed by the user.
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The initial basic algorithm is inspired from some deal function (thanks to them)
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_05_22
#REVISED 09_05_06
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
# defining ancillary functions
quequoi <- function(point) {
if (length(point) != 2) {
erreur(NULL,paste("Expecting TWO coordinates, possibly the",
"graphic device is not open for interactive way?",
"if so, just execute 'dev.off()'"));
}
# returns an integer.
# if negative, it is the number of a pressed button
# if positive, it is the number of the closest node
if ((point[1] >= xre[2]) | (point[1] < xre[1])) {
di <- (point[1] - posbut[,1])^2 + (point[2] - posbut[,2])^2;
res <- -which(min(di) == di)[1];
} else {
di <- (point[1] - gd@pos@posi[,1])^2 + (point[2] - gd@pos@posi[,2])^2;
res <- which(min(di) == di)[1];
}
res;
}
dessinne <- function() {
#######################################################
# recomputing necessary parameters for a new order
#######################################################
newp <- pos2pos(gd@pos);
rara <- range8pos(newp);
# ranges for the graph
xre <- rara$x; yre <- rara$y;
# global ranges
mx <- (xre[2] - xre[1])*pbut;
xr <- c(xre[1]-mx,xre[2]+mx);
my <- (yre[2] - yre[1])*pbut;
yr <- c(yre[1]-my,yre[2]+my);
# indicating the view
xvi <- (xr[1]+xre[1])/2;
yvi <- yre[1] + 4*my;
tvi <- paste("Theta =",
round(gd@pos@view[1]*180/pi),"deg.",
" and Phi =",
round(gd@pos@view[2]*180/pi),"deg.");
# indicating the graph
xgr <- xre[1] + 4*mx;
ygr <- (yr[2]+yre[2])/2 + my*0.3;
tgr <- paste(nbno,"nodes and",nrow(gd@arc@fle),"arc(s)",
" {{{",round(gd@pos@zoom[4],1),"}}}");
# indicating the contextual message
xme <- xre[1] + 4*mx;
yme <- (yr[1]+yre[1])/2 - my*0.3;
# defining the positions and the sizes of the buttons
posbut <- sizbut <- matrix(NA,nbut,2);
for (i in 1:(nbut-1)) {
posbut[i,1] <- (xre[2]+xr[2])/2;
posbut[i,2] <- yre[2] - i*my*1;
sizbut[i,1] <- mx*kbut;
sizbut[i,2] <- my*kbut;
}
posbut[nbut,1] <- (xre[1]+xr[1])/2;
posbut[nbut,2] <- (yre[1]+yr[1])/2;
sizbut[nbut,1] <- mx*kbut;
sizbut[nbut,2] <- my*kbut;
# defining the color of the buttons
colbut <- matrix(c("white","black"),nbut,2,byrow=TRUE);
# starting the plot
plot(0,0,type="n",#axes=FALSE,
xlim=xr,ylim=yr,
xlab="",ylab="");
# drawing the graph
plot8cgn(gd,newp@posi[,1:2]);
# adding a working frame
abline(h=yre,lty=3); abline(v=xre,lty=3);
# displaying the projection view
text(xvi,yvi,tvi,srt=90);
# displaying the graph traits
text(xgr,ygr,tgr);
# displaying the contextual message
text(xme,yme,messa[message]);
# displaying the buttons
colbut[nbut,1] <- "gray";
for (jd in 1:(nbut-1)) {
if (mode==conbut[jd]) {colbut[jd,] <- c("black","white");
} else { colbut[jd,] <- c("white","black"); }
}
for (jbd in 1:nbut) {
symbols(posbut[jbd,1],posbut[jbd,2],
rectangles=matrix(sizbut[jbd,],1,2),
bg=colbut[jbd,1],
add=TRUE,inches=FALSE);
text (posbut[jbd,1],posbut[jbd,2],
labels=conbut[jbd],col=colbut[jbd,2]);
}
list(xre=xre,yre=yre,posbut=posbut);
}
nbno <- nbnv(gn,gn@item);
# parametering the button sizes and some margin size
pbut <- 0.10; kbut <- 0.8;
# calibration of the rotation
anglemax <- pi/2;
# starting
par(mfrow=c(1,1));
messa <- c("(1/2) Click the node to move",
"(2/2) Click where to move the node",
"(1/2) Click the starting node",
"(2/2) Click the ending node",
"(1/2) Click the starting node",
"(2/2) Click the ending node",
"(1/1) Click where to put the new node",
"(1/1) Click the node to remove",
"(1/1) Click the center of the magnyfication",
"(1/1) Click the center for the reduction",
"(1/1) Click direction and angle of the rotation");
names(messa) <- c("MN","MN2","AA","AA2",
"RA","RA2","AN","RN",
"+","-","Rot");
# intitial mode
mode <- "MN"; message <- "MN";
# defining the contents of the buttons
nbut <- 10;
conbut <- c("rst","MN","AA","RA","AN","RN","+","-","Rot","Exit");
gd <- gn;
### BEGINNING OF MODIFICATION LOOP
while(TRUE) {
#######################################################
# drawing an updated screen
#######################################################
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
########################################################
# according to the mode different actions are awaited
########################################################
# exiting
if (mode == "Exit") { break;}
# resetting
if (mode == "rst") {
gd <- gn; mode <- "MN"; next; message <- mode;
}
# moving a node
if (mode=="MN") {
mode <- "MN"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the node to move
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
}
# we must get the point to move there
message <- "MN2";
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
ou <- unlist(locator(1));
nu <- quequoi(ou);
if (nu < 0) {
if (-nu == nbut) { break;}
mode <- conbut[-nu]; message <- mode;
next;
} else {
gd@pos@posi[ni,1:2] <- ou;
}
}
# adding an arc
if (mode=="AA") {
mode <- "AA"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the starting node
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
}
# we must get the ending node
message <- "AA2";
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
ou <- unlist(locator(1));
nj <- quequoi(ou);
if (nj < 0) {
if (-nj == nbut) { break;}
mode <- conbut[-nj]; message <- mode;
next;
} else {
pam <- arc2pam(gd@arc);
pam@rlt[ni,nj] <- 1;
gd@arc <- pam2arc(pam);
mode <- "AA"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
next;
}
}
# removing an arc
if (mode=="RA") {
mode <- "RA"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the starting node
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
}
# we must get the ending node
message <- "RA2";
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
ou <- unlist(locator(1));
nj <- quequoi(ou);
if (nj < 0) {
if (-nj == nbut) { break;}
mode <- conbut[-nj]; message <- mode;
next;
} else {
pam <- arc2pam(gd@arc);
pam@rlt[ni,nj] <- 0;
gd@arc <- pam2arc(pam);
mode <- "RA"; message <- mode; next;
}
}
# adding a node
if (mode=="AN") {
mode <- "AN"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get where to put a supplementary node
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
} else {
nena <- form3names(1,gn2item(gd));
gd <- and4gn(gd,nena);
gd@pos@posi[nbnv(gd,gd@item),1:2] <- ou;
mode <- "AN"; message <- mode; next;
}
}
# removing a node
if (mode=="RN") {
mode <- "RN"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the node to remove
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
} else {
gd <- rmnd4gn(gd,ni);
mode <- "RN"; message <- mode; next;
}
}
# zooming more
if (mode=="+") {
mode <- "+"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the center point for applying the zoom
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
} else {
ou[1] <- -1 + 2*(ou[1]-min(gd@pos@posi[,1]))/
(max(gd@pos@posi[,1])-min(gd@pos@posi[,1]));
ou[2] <- -1 + 2*(ou[2]-min(gd@pos@posi[,2]))/
(max(gd@pos@posi[,2])-min(gd@pos@posi[,2]));
gd@pos@zoom <- c(ou,gd@pos@zoom[3],gd@pos@zoom[4]*gd@pgr@kzoom);
mode <- "+"; message <- mode; next;
}
}
# zooming less
if (mode=="-") {
mode <- "-"; message <- mode;
uuu <- dessinne();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# we must get the center point for applying the zoom
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni]; message <- mode;
next;
} else {
ou[1] <- -1 + 2*(ou[1]-min(gd@pos@posi[,1]))/
(max(gd@pos@posi[,1])-min(gd@pos@posi[,1]));
ou[2] <- -1 + 2*(ou[2]-min(gd@pos@posi[,2]))/
(max(gd@pos@posi[,2])-min(gd@pos@posi[,2]));
gd@pos@zoom <- c(ou,gd@pos@zoom[3],gd@pos@zoom[4]/gd@pgr@kzoom);
mode <- "-"; message <- mode; next;
}
}
# rotating
if (mode=="Rot") {
mode <- "Rot"; message <- mode;
uuu <- dessinne ();
xre <- uuu$xre; yre <- uuu$yre; posbut <- uuu$posbut;
# indicating the center (start for rotation)
# center of the plot and radius
centx <- mean(xre); centy <- mean(yre);
rayon <- sqrt(diff(xre)^2+diff(yre)^2);
for (jd in 1:3) { points(centx,centy,cex=jd);}
# putting calibration rotation of 5 deg. and 10 deg.
symbols(rep(centx,2),rep(centy,2),
circles=0.5*rayon*(diff(xre)/anglemax)*pi/180*c(5,10),
add=TRUE,inches=FALSE);
# we must get Theta and Phi angles
ou <- unlist(locator(1));
ni <- quequoi(ou);
if (ni < 0) {
if (-ni == nbut) { break;}
mode <- conbut[-ni];
next;
} else {
theta <- ou[2] / diff(xre) * anglemax;
phi <- ou[1] / diff(xre) * anglemax;
gd@pos@view <- gd@pos@view + c(theta,phi);
gd@pos <- pos2pos(gd@pos);
mode <- "Rot"; next;
}
}
} ### ENDING THE CLICKING GAME
dev.off();
gd;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
read8gn <- function(fi)
#TITLE produced a /gn/ from a text file
#DESCRIPTION
# The text file must follow the structure compatible
# with \code{file2list}. The first component of the file
# must be the description of the /gn/; the remaining
# components are supposed to be the nodes.
#DETAILS
# See \code{rebastaba.etg?.txt} files to get
# straightforward examples.
#KEYWORDS
#PKEYWORDS gn file
#INPUTS
#{fi} <<The name of the file to be considered.>>
#[INPUTS]
#VALUE
# The generated /gn/ object
#REFERENCE
#SEE ALSO
#CALLING {file2list} {list2gn}
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_04_06
#REVISED 10_06_16
#--------------------------------------------
{
# reading the list
li <- file2list(fi,path="",
tags=rbsb.tag2,
sep=rbsb.sep2
);
## interpreting the list
# exploring it
ee <- explore8list(li);
# looking for all the components
ve <- bc(nrow(ee));
for (ii in bc(nrow(ee))) {
# eliminating the list ones
ve[ee[,"classes"] == "list"] <- 0;
nam <- ee[ii,"name"];
# eliminating the list ones
if (nam == "list") {ve[ii] <- 0;
# if not getting the components
} else { vava <- get8listcomp(li,ee[ii,])[[1]];}
#
# dealing with compulsory character of the description
if (expr3present(nam,c("name","orig","time","defi","role"),exact=TRUE)) {
if (length(vava) > 1) {
li <- set8listcomp(paste(vava,collapse=" "),li,ee[ii,]);
}
ve[ii] <- 0;
}
#
# dealing with the item
if (expr3present(nam,c("item"),exact=TRUE)) {
li$item <- form3norma(li$item);
ve[ii] <- 0;
}
# dealing with the link
if (expr3present(nam,c("link"),exact=TRUE)) {
if (length(vava) > 1) {
vava <- form3norma(vava," ",">",">");
vava <- form3decadre(vava);
li <- set8listcomp(vava,li,ee[ii,]);
}
ve[ii] <- 0;
}
}
#
if (any(ve>0)) {
nochecked <- ee[ve>0,,drop=FALSE];
# form3affiche(nochecked);
}
#
# getting the gn
gn <- list2gn(li);
# precautionary checking
if (g4n.mck) {check4valid(valid8gn(gn));}
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
minbar8gn <- function(gn)
#TITLE finds the minimum number of arcs between nodes of a gn object
#DESCRIPTION
# Finds the minimum number of arcs between nodes of a gn object.
# To do so, the parentship is explored and a matrix is returned.
# This matrix is similar to the pam matrix but is richer. Its
# rows and columns are associated to each node. [i,j] is the minimum
# number of arcs to follow to go from node i to node j. When this
# is not possible, a value of -1 is introduced.
#DETAILS
# Own nodes are considered as zero distance children (in
# other words the diagonal of the resulting matrix is not
# -1 but 0).
#KEYWORDS utilities
#PKEYWORDS gn genealogy
#INPUTS
#{gn} <<The gn object to be investigated>>
#[INPUTS]
#VALUE
# a matrix (see DESCRIPTION field)
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# minbar8gn(g4n.gn7);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The transposed matrix has a similar interpretation
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_07
#REVISED 09_06_09
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8gn(gn));}
nbno <- nbnv(gn,gn@item);
noms <- gn2item(gn);
# particular cases
if (nbno < 2) {
return(matrix(0,nbno,nbno,dimnames=list(noms,noms)));
}
# initialization
res <- matrix(-1,nbno,nbno);
res <- res + diag(nbno);
dimnames(res) <- list(noms,noms);
# doing it
nbf <- 0; # nbr of arcs to obtain the child
nba <- 1; # nbr of added children during the loop
while (nba > 0) {
nbf <- nbf + 1; nba <- 0;
for (jbd in 1:nbno) {
enf <- which(res[jbd,] != -1); # children for nodes jbd
pos <- which(apply(outer(gn@arc@fle[,1],enf,"=="),1,sum)==1); # starting arcs
nenf <- gn@arc@fle[pos,2]; # possible new children
nenf <- setdiff(nenf,enf);# actual new children
if (length(nenf) > 0) {
nba <- nba + length(nenf);
res[jbd,nenf] <- nbf;
}
}
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
and4gn <- function(gn,names=1,pos=NULL)
#TITLE adds a series of nodes to a gn object
#DESCRIPTION
# This function adds a series of nodes to a /gn/
# without any links giving them the names into
# argument 'names'. They are unidimensional with
# empty variable names.
#DETAILS
# With respect to the internal order, the new nodes
# are introduced at the end.
#KEYWORDS
#PKEYWORDS gn nd
#INPUTS
#{gn}<<The object gn to be completed>>
#[INPUTS]
#{names} <<(=1) when numeric of length 1, it
# indicates the number of nodes to add
# (and the name will be automatically
# determined by form3names function.
# When character it is the vector
# of the new names and its length gives
# the number of node to add.>>
#{pos} <<(=NULL) gives the positions to add.
# When null, they will be automatically provided.
# When a matrix, it must comprise as many rows as
# new nodes and 2 (x,y) or 3 (x,y,z) columns.>>
#VALUE
# The completed object gn
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# and4gn(g4n.gn7,c("U","V","W"));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_11_12
#REVISED 09_05_06
#--------------------------------------------
{
# checking and preparing
if (g4n.mck) {check4valid(valid8gn(gn));}
if (gn@item!="n") {
erreur(gn,"For the moment, adn4gn does not work when the slot item is not 'n'");
}
# about the new names
items <- gn2item(gn);
if (is.numeric(names)) {
check4tyle(names,"any",1,message="When numeric, names must be a single integer.");
names <- form3names(names,items);
}
if (!all(outer(items,names,"!="))) {
erreur(list(gn@nom,names),"Some names for new nodes already exists!");
}
nbnn <- length(names);
# about the new positions to give
if (!isvide(pos)) {
if (!is.matrix(pos)) {
erreur(pos,"When non null, 'pos' must be a matrix!");
}
if((nrow(pos) != nbnn) | !(ncol(pos) %in% c(2,3))) {
erreur(dim(pos),"When a matrix, pos must have 2 or 3 columns",
"and a number of rows identical to the number",
"of nodes to add");
}
}
###
### adapting the /gn/
#
# completing the nodes
for (nn in names) { gn@nom@x[[nn]] <- ""; }
#
# completing the arcs
gn@arc@nbn <- length(gn2item(gn,check=FALSE));
#
# completing the positions
if (is.null(pos)) {
angles <- (1:nbnn)*2*pi/nbnn;
xr <- range(gn@pos@posi[,1]);
yr <- range(gn@pos@posi[,2]);
cen <- c(mean(xr),mean(yr));
rad <- c(diff(xr),diff(yr))/2;
pos <- cbind(rad[1]*cos(angles),rad[2]*sin(angles)) +
outer(rep(1,nbnn),cen,"*");
}
if (ncol(pos == 2)) { pos <- cbind(pos,rep(0,nbnn),rep(0,nbnn));
} else { pos <- cbind(pos,rep(0,nbnn));}
gn@pos@posi <- rbind(gn@pos@posi,pos);
# returning
gn;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
ends8gn <- function(gn)
#TITLE returns the root and leaf nodes/variables of a gn
#DESCRIPTION
# From a /gn/ object, the set of nodes/variables
# is partitioned in four classes:\cr
# (i) the root and leaf nodes/variables,\cr
# (ii) the root but not leaf nodes/variables,\cr
# (iii) the leaf but not root nodes/variables,\cr
# (iv) the remaining nodes/variables.\cr
# Of course, some of the classes can be empty.
#DETAILS No check about \code{gn}
#KEYWORDS
#PKEYWORDS bn gn
#INPUTS
#{gn}<<The gn.>>
#[INPUTS]
#VALUE
# a list of four named numeric vectors with the iin
# of the corresponding nodes/variables and the names as names.
# The four items are $RaL (root and leaf), $RwL (root
# but not leaf), $LwR (leaf but not root) and $rema (the
# remaining nodes/variables).
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# ends8gn(g4n.gn7);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_01
#REVISED 09_10_16
#--------------------------------------------
{
# determining the number of nodes/variables
nbn <- nbnv(gn,gn@item);
# preparing the resulting list
res <- vector("list",4);
names(res) <- c("RaL","RwL","LwR","rema");
for (i in 1:4) { res[[i]] <- numeric(0);}
# getting the parentship
pare <- neighbours8gn(gn,"parents");
chil <- neighbours8gn(gn,"children");
# filling the list
par <- chi <- numeric(nbn);
for (nn in bc(nbn)) {
par <- length(pare[[nn]]);
chi <- length(chil[[nn]]);
if (par == 0) {
if (chi == 0) {
res$RaL <- c(res$RaL,nn);
} else {
res$RwL <- c(res$RwL,nn);
}
} else {
if (chi == 0) {
res$LwR <- c(res$LwR,nn);
} else {
res$rema <- c(res$rema,nn);
}
}
}
# adding the names
nana <- gn2item(gn);
for (i in 1:4) { names(res[[i]]) <- nana[res[[i]]];}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
neighbours8gn <- function(gn,what="parents")
#TITLE returns the direct parents (or children) of a gn nodes
#DESCRIPTION
# Returns the parents/children of all nodes (or all variables
# according to \code{gn@item}) of 'gn'.
#DETAILS
# Parents means direct parents; children means direct children
#KEYWORDS
#PKEYWORDS genealogy
#INPUTS
#{gn}<<the gn object.>>
#[INPUTS]
#{what} << either \code{parents} or \code{children} accordingly.>>
#VALUE
# A list of character vectors containing the names of the parents,
# each component of the list is associate to an item (node or
# variable). When there is no parent, character(0) is returned.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# neighbours8gn(g4n.gn7,"parents");
# neighbours8gn(g4n.gn7,"children");
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_16
#REVISED 09_10_16
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8gn(gn));}
if (!expr3present(what,c("parents","children"))) {
erreur(what,"'what' must be 'parents' or 'children'");
}
# getting the parents or children
nbn <- gn@arc@nbn;
if (nbn==0) { return(rbsb.lis0); }
res <- vector("list",nbn);
nnom <- gn2item(gn);
for (ii in bc(nbn)) { res[[ii]] <- character(0);}
for (ii in bc(nrow(gn@arc@fle))) {
chi <- gn@arc@fle[ii,2];
chn <- nnom[chi];
pai <- gn@arc@fle[ii,1];
pan <- nnom[pai];
#
if (expr3present(what,"parents")) {
res[[chi]] <- c(res[[chi]],pan);
} else {
res[[pai]] <- c(res[[pai]],chn);
}
}
# naming the result
names(res) <- nnom;
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
###########################################
###########################################
########
#((((((( NEW S4 CLASS ion
########
###########################################
###########################################
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
cycle8pam <- function(pam)
#TITLE detects if a cycle exists from a pam matrix
#DESCRIPTION (ba)
# This function returns TRUE or FALSE if at least one cycle
# is detected within the graph defined by the pam matrix.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS pam cycle
#INPUTS
#{pam} <<The pam matrix>>
#[INPUTS]
#VALUE
# logical variable (TRUE: at least a cycle, FALSE : no cycle).
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# papa <- new("pam",rlt=matrix(c(0,0,1,1,0,0,0,1,0),3));
# cycle8pam(papa);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_10
#REVISED 07_10_19
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pam(pam));}
# initialization
nbn <- nrow(pam@rlt);
res <- numeric(0);
nbfait <- -1;
# starting the stupid loop
while (nbfait < length(res)) {
nbfait <- length(res);
for (jbd in bc(nbn)) {
papa <- which(pam@rlt[,jbd]==1);
if (length(unique(c(jbd,papa,res))) == (1+length(res))) {
res <- c(res,jbd);
}
}
}
if ((length(res)) != nbn) { res <- TRUE;
} else { res <- FALSE;}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
explore8pam <- function(pam,iir=bc(nrow(pam@rlt)),jjc=iir)
#TITLE finds different characteristics of relations
# between nodes
#DESCRIPTION (ba)
# exploring the parentship matrix 'pam', returns a list
# of different nodesxnodes matrices giving standard
# characteristics of the relationship between them.\cr
# The calculation is done with iin order
# and the result is proposed in iin order.
# The relation are:
# (i) the indication of the relation (-1=row is descendant,
# 0= none, 1= row is ascendant),
# (ii) the minimum number of arcs to join row and column
# (0 means no)
# (iii) the maximum number of arcs to join row and column
# (0 means no)
# (iv) the number of different paths joining row and column
#DETAILS
#KEYWORDS utilities
#PKEYWORDS bn gn
#INPUTS
#{pam} <<The pam object>>
#[INPUTS]
#{iir} << the subset of nodes to be considered
# as starting nodes. They will be en rows of the
# resulting matrices.>>
#{jjc} << the subset of nodes to be considered as ending
# nodes. They will be in columns of the resulting matrices.>>
#VALUE
# a list gathering two lists
# $des: a list of descriptions explaining what is
# computed in the differents matrices
# $rel: the list of the computed matrices
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# explore8pam(g4n.pam1);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# a former version of this function was called 'genea'
#FUTURE
# It could be more logical (and efficient when the number
# of nodes is important) that the matrices be replaced
# with couples of nodes...
#AUTHOR J.-B. Denis
#CREATED 07_06_17
#REVISED 09_05_10
#--------------------------------------------
{
# checking
if (g4n.mck) {check4valid(valid8pam(pam));}
pama <- pam@rlt; nbn <- nrow(pama);
if (!all(iir %in% 1:nbn)) {
erreur(iir,"is not acceptable for dim(pama) =",dim(pama));
}
if (!all(jjc %in% 1:nbn)) {
erreur(jjc,"is not acceptable for dim(pama) =",dim(pama));
}
if (length(unique(iir)) < length(iir)) {
erreur(iir,"repetitions are not accepted!");
}
if (length(unique(jjc)) < length(iir)) {
erreur(jjc,"repetitions are not accepted!");
}
# defining the objects
d1 <- new("des",orig="",time="",role="",
name="relation",
defi=paste("0 when no relation,",
"1 when the row is an ascendant of the column,",
"-1 when the row is a descendant of the column."));
d2 <- new("des",orig="",time="",role="",
name="minimum",
defi=paste("0 when no relation,",
"otherwise the minimum number of arcs between",
"the two nodes."));
d3 <- new("des",orig="",time="",role="",
name="maximum",
defi=paste("0 when no relation,",
"otherwise the maximum number of arcs between",
"the two nodes."));
d4 <- new("des",orig="",time="",role="",
name="number",
defi=paste("0 when no relation,",
"otherwise the number of different paths",
"following the arcs to go from one node",
"to the other."));
# finding the relationship matrices
pama <- pam@rlt;
pamb <- t(pama);
m1 <- pama - pamb;
m2 <- m3 <- m4 <- pama + pamb;
ka <- pama; kb <- pamb;
for (ii in (1+bc(nbn-2))) {
ka <- ka %*% pama; kb <- kb %*% pamb;
m1 <- m1 + ka - kb;
m2[(m2==0)&((ka>0)|(kb>0))] <- ii;
m3[ ((ka>0)|(kb>0))] <- ii;
m4 <- m4 + ka + kb;
}
nana <- list(iir,jjc);
m1 <- m1[iir,jjc,drop=FALSE]; dimnames(m1) <- nana;
m2 <- m2[iir,jjc,drop=FALSE]; dimnames(m2) <- nana;
m3 <- m3[iir,jjc,drop=FALSE]; dimnames(m3) <- nana;
m4 <- m4[iir,jjc,drop=FALSE]; dimnames(m4) <- nana;
list(des=list(d1,d2,d3,d4),
rel=list(m1,m2,m3,m4));
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
mindis8pam <- function(pam)
#TITLE finds the minimum distance between every pair of nodes
#DESCRIPTION (ba)
# From the parentship matrix, the minimum distance matrix between
# every pairs of nodes is computed. [i,j] means from node ith to node
# jth. In most cases (especially for non empty dags) the matrix is
# not symmetric.\cr
# The distance (not a mathematical distance) is the minimal number of
# arcs to follow before reaching the node j starting from the node i.
#DETAILS
# -1 are introduced on the diagonal.
#KEYWORDS utilities
#PKEYWORDS pam
#INPUTS
#{pam} <<The pam matrix to be investigated>>
#[INPUTS]
#VALUE
# The matrix containing the distances
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# mindis8pam(g4n.pam1);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# The transposed matrix is also of value
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_24
#REVISED 07_11_07
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pam(pam));}
nbno <- nrow(pam@rlt);
mm <- res <- pam@rlt;
# going on
if (nbno > 2) { for (jbd in 2:(nbno-1)) {
mm <- mm %*% pam@rlt;
res[(res==0)&(mm>0)] <- jbd;
}}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
pos2pos <- function(pos)
#TITLE returns the equivalent pos object with standard view
#DESCRIPTION (ba)
# This function returns the equivalent pos object with standard view
# (i.e. view=c(0,0)). The central point of zoom is modified
# accordingly.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS plot pos
#INPUTS
#{pos} <<the pos object to be modified>>
#[INPUTS]
#VALUE
# The transformed pos object
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(pos2pos(g4n.pos0));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
# At the beginning, pos2pos was called projection since it is
# the way to obtain the coordinates (in new (x,y)) for the
# representation.
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_25
#REVISED 07_11_12
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pos(pos));}
xyz <- rbind(pos@posi[,1:3],pos@zoom[1:3]);
for (jbd in bc(nrow(xyz))) {
uu <- xyz[jbd,];
vv <- geom3xyz2pol(uu);
vv[2:3] <- vv[2:3] + pos@view;
xyz[jbd,] <- geom3pol2xyz(vv);
}
if (nrow(xyz) > 1) { pos@posi[,1:3] <- xyz[-nrow(xyz),];}
pos@zoom[1:3] <- xyz[nrow(xyz),];
# returning
pos;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
pam2path <- function(pam,d,a)
#TITLE returns all paths between two nodes
#DESCRIPTION (ba)
# From the parentship matrix computes recursively
# all paths between two nodes.
#DETAILS
# The basic idea is quite simple. All paths
# between d (departure) and a (arrival) are the
# paths between every children of d and a, so
# a recursive procedure can be used.
#KEYWORDS utilities
#PKEYWORDS genealogy
#INPUTS
#{pam} <<pam object>>
#{d} <<departure node (internal number)>>
#{a} <<arrival node (internal number)>>
#[INPUTS]
#VALUE
# a list of vectors describing all possible paths
# going from d to a. The list is sorted according to
# the length of the path.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# pam2path(g4n.pam1,1,5);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_09_12
#REVISED 07_10_19
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pam(pam));}
# is the final node reached?
if (d == a) {
res <- list(d);
}
else {
# initialization
res <- vector("list",0);
# looking for the d children
ee <- which(1==pam@rlt[d,]);
# is there no child?
if (length(ee) == 0) {
res <- -1;
}
else {
# loop over all children from node d
for (jbd in ee) {
# computing the paths from this children
ff <- Recall(pam,jbd,a);
# is there a valid path?
if (is.list(ff)) {
# preparing a list with the right dimension
nres <- vector("list",length(res)+length(ff));
# copying the previous components
if (length(res)>0) { for (jd in 1:length(res)) {
nres[[jd]] <- res[[jd]];
}}
# adding the component with this child
if (length(ff)>0) { for (jd in 1:length(ff)) {
nres[[jd+length(res)]] <- c(d,ff[[jd]]);
}}
# storing to continue the loop
res <- nres;
}
else {
res <- -1;
}
}
}
}
# removing component -1 (means no path)
if (length(res) > 0) {
ko <- 0;
for (i in length(res)) {
if (identical(res[[i]],-1)) { ko <- 1+ko;}
}
if (ko > 0) {
uu <- vector("list",length(res)-ko);
ik <- 0;
for (i in length(res)) {
if (!identical(res[[i]],-1)) {
ik <- 1+ik;
uu[[ik]] <- res[[i]];
}
}
res <- uu;
}
}
# sorting the list
if (length(res) > 1) {
long <- rep(NA,length(res));
for (yd in 1:length(res)) { long[yd] <- length(res[[yd]]);}
res <- res[order(long)];
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
arc2pam <- function(arc)
#TITLE constructs the object pam from the object arc
#DESCRIPTION (ba)
# exploring the matrix arc@fle, returns a binary matrix with
# rows associated to each node giving their children.
# 0 means that this column is not a children as a pam object.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS genealogy arc pam
#INPUTS
#{arc} <<The arc object>>
#[INPUTS]
#VALUE
# the pam object
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(g4n.arc0);
# print(arc2pam(g4n.arc0));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_10
#REVISED 07_10_18
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8arc(arc));}
nbno <- arc@nbn;
res <- new("pam",rlt=matrix(0,nbno,nbno));
# doing it
for (jbd in bc(nrow(arc@fle))) {
res@rlt[arc@fle[jbd,1],arc@fle[jbd,2]] <- 1;
}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
pam2arc <- function(pam)
#TITLE from the parentship object pam returns the arcs object
#DESCRIPTION (ba)
# from the parentship object pam returns the arcs object
#DETAILS
#KEYWORDS utilities
#PKEYWORDS genealogy arc pam
#INPUTS
#{pam} <<The object pam.>>
#[INPUTS]
#VALUE
# the arc object.
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# print(pam2arc(g4n.pam0));
# print(pam2arc(g4n.pam1));
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_10_18
#REVISED 09_10_20
#--------------------------------------------
{
if (g4n.mck) {check4valid(valid8pam(pam));}
nbno <- nrow(pam@rlt);
res <- new("arc",nbn=nbno,fle=matrix(0,0,3));
# doing it
for (jbd in bc(nbno)) { for (jd in bc(nbno)) {
if (pam@rlt[jbd,jd] == 1) {
res@fle <- rbind(res@fle,c(jbd,jd,211));
}
}}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
geneal4pam <- function(pam,i,asc=TRUE)
#TITLE constructs the genealoty of a given node
#DESCRIPTION (ba)
# This function constructs the genealoty of a given node,
# that is returns the graph of all ascendants (descendants)
# starting from this node.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS genealogy
#INPUTS
#{pam} <<The pam matrix describing the parentship.>>
#{i} <<The considered node.>>
#[INPUTS]
#{asc} << must ascendants be looked for, if not
# the descendants.>>
#VALUE
# an arc object describing the obtained tree
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# geneal4pam(g4n.pam1,2);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_11_07
#REVISED 09_10_13
#--------------------------------------------
{
# starting
if (g4n.mck) {
check4valid(valid8pam(pam));
check4tyle(i,"numeric",1,message="Only one node at once");
}
nbn <- nrow(pam@rlt);
if ((i<1) | (i>nbn)) { erreur(NULL,"the node",i,"does not fit with the pam provided.");}
if (asc) { pam@rlt <- t(pam@rlt);}
res <- new("arc",nbn=nbn,fle=matrix(0,0,3));
# the included nodes
nin <- i;
# finding all involved nodes
ajout <- 1;
while (ajout > 0) {
ajout <- 0;
#cat("----------",ajout,"\n");
for (noe in nin) {
#cat("(((",nin,")))",noe,"\n");
pot <- which(pam@rlt[noe,] == 1);
#cat("|||",pot,"|||\n");
for (po in bf(pot)) {
p <- pot[po];
if (!(p %in% nin)) {
#cat("uuu\n");
nin <- c(nin,p);
ajout <- ajout+1;
}
}
}
}
# deducing the restricted graph
for (i in bf(nin)) {
ii <- nin[i];
for (j in bf(nin)) {
jj <- nin[j];
if (pam@rlt[ii,jj] == 1) {
res@fle <- rbind(res@fle,c(ii,jj,211));
}
}
}
if (asc) { res@fle[,1:2] <- res@fle[,c(2,1)];}
if (g4n.mck) {check4valid(valid8arc(res));}
# returning
res;
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
range8pos <- function(pos,padding=g4n.pgr0@padding)
#TITLE returns the ranges (x,y) for a pos
#DESCRIPTION (ba)
# This function returns the ranges (x,y) for a pos
# taking into account the zoom specification of the pos
# and the extreme values of its positions.
#DETAILS
#KEYWORDS utilities
#PKEYWORDS geometry
#INPUTS
#{pos} <<The pos object.>>
#[INPUTS]
#{padding} <<The padding coefficient to apply.>>
#VALUE
# a list with two components \$x and \$y giving
# the ranges (min,max) of the two first positions
#EXAMPLE
# g4n3k("RESET"); # needed only for R checking, to be forgotten
# uu <- new("pos",posi=matrix(round(10*cos(1:20)),5));
# range8pos(uu);
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 07_11_07
#REVISED 07_11_07
#--------------------------------------------
{
xra <- diff(range(pos@posi[,1]))/2;
yra <- diff(range(pos@posi[,2]))/2;
# computing the middle point of the nodes
xmi <- mean(range(pos@posi[,1]));
ymi <- mean(range(pos@posi[,2]));
# computing the range of the representation
xm <- xmi + xra*pos@zoom[1];
ym <- ymi + yra*pos@zoom[2];
xr <- xm + padding*c(-1,1)*xra/pos@zoom[4];
yr <- ym + padding*c(-1,1)*yra/pos@zoom[4];
list(x=xr,y=yr);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
new8arc <- function(nbno,nbar)
#TITLE creates an /arc/ with a specified number of nodes and arcs
#DESCRIPTION (ba)
# After checking that it is possible, returns an /arc/ object
# with the specified number of nodes (\code{nbno}) and arcs (\code{nbar}).
#DETAILS
#KEYWORDS misc
#PKEYWORDS arc
#INPUTS
#{nbno}<<Number of desired nodes.>>
#{nbar}<<Number of desired arcs.>>
#[INPUTS]
#VALUE
# A valid \code{arc} object. If not possible,
# a fatal error is issued
#EXAMPLE
# g4n3k("RESET"); # For R checking to be forgetten
# new8arc(10,5);
# \dontrun{new8arc(3,4);}
#REFERENCE
#SEE ALSO
#CALLING
#COMMENT
#FUTURE
#AUTHOR J.-B. Denis
#CREATED 09_10_20
#REVISED 09_10_20
#--------------------------------------------
{
# checking
if (g4n.mck) {
check4tyle(nbno,"integer",1,message="nbno is the number of nodes");
check4tyle(nbar,"integer",1,message="nbar is the number of arcs");
if (nbno < 0) { erreur(nbno,"nbno is the number of nodes");}
if (nbar < 0) { erreur(nbar,"nbar is the number of arcs");}
if (nbar > nbno*(nbno-1)/2) {
erreur(list(nbno,nbar),"Too much arcs for the number of nodes");
}
}
#
# filling the @fle matrix
fle <- matrix(211,nbar,3);
nba <- 0;
for (dep in bc(nbno)) { for (arr in bc(nbno)) {
if (dep<arr) { if (nba < nbar) {
nba <- nba + 1;
fle[nba,1:2] <- c(dep,arr);
}}}}
# returning
new("arc",nbn=nbno,fle=fle);
}
#>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Try the g4n 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.