## f3-vertexAndEdge.R ---
## Author : Jens Henrik Badsberg, Claus Dethlefsen, Luca La Rocca
## Created On : Tue Nov 30 14:32:00 2004
## Last Modified By: Luca La Rocca
## Last Modified On: Fri Feb 15 13:18:00 2008
## Update Count : 28
## Status : Unknown, Use with caution!
######################################################
### ----------------------------------vertices---------------------------------------
## construction and visualization
# constructor method for class 'vertexSet'
setMethod("initialize","vertexSet",
function(.Object,...){
id<-unique(as(unlist(list(...)),"character")) # get unique 'character' values
if(length(id)>0)
.Object@.Data<-make.names(id,unique=TRUE) # make unique valid names
return(.Object)
} # end of function
) # end of SetMethod
# 'new("vertexSet",x,y)' returns a 'vertexSet' object consisting of a vector of
# unique syntactically valid names made from the unique elements of 'x' and 'y'
# wrapper for 'vertexSet' construction
v <- function(...) new("vertexSet",...)
# just call the right initialize method
# show method for class 'vertexSet'
setMethod("show","vertexSet",
function(object)
cat("{",paste(object@.Data,collapse=","),"}",sep="",fill=T)
) # end of setMethod
# for example '{X1,X2,X3}' denotes a three element 'vertexSet'
## getting and setting information
# 'names' method for class 'vertexSet'
setMethod("names","vertexSet",function(x) x@.Data)
# data part is returned
# 'card' method is inherited from class 'vector'
## property checking
# 'isEmpty' method is inherited from class 'vector'
# comparison method for class 'vertexSet'
setMethod("areTheSame", c("vertexSet", "vertexSet"), function(x,y) setequal(x@.Data,y@.Data))
# a 'logical' value answering the question is returned
## extraction
# multi extractor method for class 'vertexSet'
setMethod("[","vertexSet",function(x,i,j=NA,drop=NA){
if(isEmpty(x)) x
else new("vertexSet",x@.Data[i])
} # end of function
) # end of setMethod
# a subset of vertices is extracted
# single extractor method for class 'vertexSet' gives a 'character' object
## typecasting
# typecasting method from 'vector' to 'vertexSet'
setAs("vector","vertexSet",function(from,to) new(to,from))
# just call the constructor with 'vector' input
# on the other hand, typecasting from 'vertexSet' to 'vector'
# is automatic and gives the '.Data' slot of the 'vertexSet' object
## operators
# union method for 'vertexSet' and 'vertexSet'
setMethod("+",c("vertexSet","vertexSet"),
function(e1,e2) new("vertexSet",union(e1@.Data,e2@.Data))
) # end of setMethod
# the union of the two vertex sets is returned
# intersection method for 'vertexSet' and 'vertexSet'
setMethod("*",c("vertexSet","vertexSet"),
function(e1,e2) new("vertexSet",intersect(e1@.Data,e2@.Data))
) # end of setMethod
# the intersection of the two vertex sets is returned
# asymmentric difference method for 'vertexSet' and 'vertexSet'
setMethod("-",c("vertexSet","vertexSet"),
function(e1,e2) new("vertexSet",setdiff(e1@.Data,e2@.Data))
) # end of setMethod
# the asymmetric difference of the two vertex sets is returned
### ----------------------------------edges------------------------------------
## construction and visualization
# constructor method for class 'undirectedEdge'
setMethod("initialize","undirectedEdge",
function(.Object,...){
id<-unique(as(unlist(list(...)),"integer")) # get unique 'integer' values
if(length(id)>0)
.Object@.Data<-id[id>0&!is.na(id)] # keep strictly positive values only
return(.Object)
} # end of function
) # end of SetMethod
# 'new("undirectedEdge",x,y)' returns an 'undirectedEdge' object consisting of a vector of
# unique strictly positive 'integer' numbers made from the unique elements of 'x' and 'y'
# constructor method for class 'directedEdge'
setMethod("initialize","directedEdge",
function(.Object,...){
Args <- list(...) # get the arguments
if(length(Args)==1) # handle single argument case
Args<-Args[[1]]
if(length(Args)==0) # empty object
.Object@.Data<-list()
else{ # process the arguments
if(is(Args,"list")){ # unlist and store order information
Ords<-numeric(0)
for(i in 1:length(Args))
Ords<-c(Ords,rep(i,length(unlist(Args[[i]]))))
Args<-unlist(Args)
} else # order information is trivial
Ords<-seq(1,length(Args))
# make 'integer'
Args<-as(Args,"integer")
# keep strictly positive
Args<-Args[Args>0&!is.na(Args)]
Ords<-Ords[Args>0&!is.na(Args)]
# remove duplicates
dups<-duplicated(Args)
Args<-Args[!dups]
Ords<-Ords[!dups]
# construct the data part
res<-list()
len<-length(Args)
if(len>0){ # otherwise nothing to be done
preOrd<-0 # previous order
curVer<-0 # current vertex
for(i in 1:len){ # scan the arguments
if(Ords[i]>preOrd){ # new vertex
res<-c(res,list(Args[i]))
preOrd<-Ords[i]
curVer<-curVer+1
} else # same vertex
res[[curVer]]<-c(res[[curVer]],Args[i])
} # end of for
} # end of if
# fill object
.Object@.Data<-res
} # end of if-else
return(.Object)
} # end of function
) # end of setMethod
# returns a 'directedEdge' object whose data part is a 'list' of 'integer' vectors
# constructor method for class 'edgeList'
setMethod("initialize","edgeList",
function(.Object,...){
Args <- list(...) # get the arguments
if ( length(Args) >1) { # more than one argument
# just keep those of class 'edge'
Args<-Args[unlist(lapply(Args,"is",class2="edge"))]
}else if((length(Args) == 1)&&(!is(Args[[1]],"edge"))&&(is(Args[[1]],"list"))){
# single 'list' argument (not an 'edge')
# keep its elements of class 'edge', if any
if (length(Args[[1]])>0){ # at least one element
Args<-Args[[1]][unlist(lapply(Args[[1]],"is",class2="edge"))]
} else Args<-Args[[1]] # empty list
} # end of if-else
callNextMethod(.Object,Args) # create new object
} # end of function
) # end of setMethod
# returns an 'edgeList' object whose data part is a 'list'
# containing (only) the arguments of class 'edge'
# wrapper for undirected edge construction
u <- function(...) new("undirectedEdge",...)
# just call the right initialize method
# wrapper for directed edge construction
d <- function(...) new("directedEdge",...)
# just call the right initialize method
# wrapper for reverse construction
r <- function(...) {
Args<-list(...)
if(length(Args)==1) Args<-Args[[1]]
new("directedEdge",rev(Args))
} # end of function
# just call the right initialize method
# show method for class 'undirectedEdge'
setMethod("show","undirectedEdge",
function(object){
if(length(object)>1){
cat(object@.Data,sep="--",fill=TRUE)
} else if (length(object)==1){
cat(object@.Data,"<>",object@.Data,sep="",fill=TRUE)
} else{ # 'length(object)==0'
cat("--",fill=TRUE)
} # end of if-else if-else
} # end of function
) # end of setMethod
# for example '--' denotes the empty 'undirectedEdge'
# '1<>1' denotes a loop and '1--2' an ordinary 'undirectedEdge'
# while 1--2--3 denotes a three vertex 'undirectedEdge'
# 'showRel' method for class 'undirectedEdge' with reference to a 'vertexSet' object
setMethod("showRel",c(object="undirectedEdge",code="vertexSet"),
function(object,code){
if(length(object)>1){
cat(code@.Data[object@.Data],sep="--",fill=TRUE)
} else if (length(object)==1){
cat(code@.Data[object@.Data],"<>",code@.Data[object@.Data],sep="",fill=TRUE)
} else{ # 'length(object)==0'
cat("--",fill=TRUE)
} # end of if-else if-else
} # end of function
) # end of setMethod
# for example '--' denotes the empty 'undirectedEdge'
# 'a<>a' denotes a loop and 'a--b' an ordinary 'undirectedEdge'
# while a--b--c denotes a three vertex 'undirectedEdge'
# show method for class 'directedEdge'
setMethod("show","directedEdge",
function(object){
len<-length(object)
if(len>1) # proper directed edge
buf<-paste(unlist(lapply(object@.Data,"paste",collapse="--")),collapse="->")
else{ # loop or empty
buf<-"->"
if (len==1) buf<-paste(buf,paste(object[[1]],collapse="--"),sep="")
} # end of if-else
cat(buf,fill=TRUE)
} # end of function
) # end of setMethod
# for example '->' denotes the empty 'directedEdge'
# '->1' denotes a loop and '1->2' an ordinary 'directedEdge'
# while 1->2--3->4 denotes a general 'directedEdge'
# 'showRel' method for class 'directedEdge' with reference to a 'vertexSet' object
setMethod("showRel",c(object="directedEdge",code="vertexSet"),
function(object,code){
len<-length(object)
if(len>1) # proper directed edge
buf<-paste(unlist(lapply(object@.Data,function(x){
paste(code@.Data[x],collapse="--")
} # end of function
)),collapse="->")
else{ # loop or empty
buf<-"->"
if (len==1) buf<-paste(buf,paste(code@.Data[object[[1]]],collapse="--"),sep="")
} # end of if-else
cat(buf,fill=TRUE)
} # end of function
) # end of setMethod
# for example '->' denotes the empty 'directedEdge'
# '->a' denotes a loop and 'a->b' an ordinary 'directedEdge'
# while a->b--c->d denotes a general 'directedEdge'
# show method for class 'edgeList'
setMethod("show","edgeList",
function(object){
cat("{",fill=T)
lapply(object,"show")
cat("}",fill=T)
} # end of function
) # end of setMethod
# just show all edges in the list
# 'showRel' method for class 'edgeList'
setMethod("showRel",c(object="edgeList",code="vertexSet"),
function(object,code){
cat("{",fill=T)
lapply(object,"showRel",code=code)
cat("}",fill=T)
} # end of function
) # end of setMethod
# just show all edges in the list
## getting and setting information
# 'maxId' method for 'undirectedEdge'
setMethod("maxId","undirectedEdge", function(x) if(length(x)==0) return(0) else return(max(x)))
# gets the maximum numeric identifier of the edge
# 'maxId' operator for 'directedEdge'
setMethod("maxId","directedEdge", function(x) if(length(x)==0) return(0) else return(max(unlist(x))))
# gets the maximum numeric identifier of the edge
# 'maxId' operator for 'edgeList'
setMethod("maxId","edgeList", function(x) if(length(x)==0) return(0) else return(max(unlist(lapply(x,"maxId")))))
# gets the maximum numeric identifier of the multi-set
# recode method for class 'undirectedEdge' (from a vertex set to a new one)
setMethod("recode",c(object="undirectedEdge",src="vertexSet",dst="vertexSet"),
function(object,src,dst) new("undirectedEdge",match(src[object],dst)))
# dropping all vertices that are not present in both of them
# recode method for class 'directedEdge' (from a vertex set to a new one)
setMethod("recode",c(object="directedEdge",src="vertexSet",dst="vertexSet"),
function(object,src,dst){
res<-lapply(object@.Data,function(x){
match(src[x],dst)
}) # end of lapply
nas<-unlist(lapply(res,"is.na"))
if(is(nas,"NULL"))
return(new("directedEdge"))
else
return(new("directedEdge",res[!nas]))
}) # end of setMethod
# dropping all vertices that are not present in both of them
# recode method for class 'edgeList' (from a vertex set to a new one)
setMethod("recode",c(object="edgeList",src="vertexSet",dst="vertexSet"),
function(object,src,dst) new("edgeList",lapply(object,"recode",src=src,dst=dst))
) #Êend of setMethod
# every edge in the multi-set is dealt with by the appropriate recode method
# 'card' method for class 'directedEdge'
setMethod("card","directedEdge",
function(object,...){
length(unlist(object))
} # end of function
) # end of setMethod
# just unlist before taking length
## property checking
# 'isEmpty' method is inherited from class 'vector'
# 'isPresent' method for 'edge' in 'edgeList'
setMethod("isPresent",c("edge","edgeList"),
function(el,ou) any(unlist(lapply(ou,"areTheSame",y=el)))
) # end of setMethod
# a 'logical' value answering the question is returned
# comparison method for class 'undirectedEdge'
setMethod("areTheSame", c("undirectedEdge", "undirectedEdge"), function(x,y) setequal(x@.Data,y@.Data))
# a 'logical' value answering the question is returned
# comparison method for class 'directedEdge'
setMethod("areTheSame", c("directedEdge", "directedEdge"),
function(x,y){
len<-length(x)
if(len==length(y)){ # maybe
res<-TRUE
i<-1
while(i<=len){
res<-res&&areTheSame(x[[i]],y[[i]])
i<-i+1
} # end of while
}else # no for sure
res<-FALSE
return(res)
} # end of function
) # end of setMethod
# a 'logical' value answering the question is returned
# comparison method for class 'edge' versus 'edge'
setMethod("areTheSame", c("edge", "edge"), function(x,y) return(FALSE))
# this will be used when comparing edges of different type
# comparison method for class 'edgeList'
setMethod("areTheSame", c("edgeList", "edgeList"),
function(x,y){
res<-(length(x)==length(y))
if(res&&!isEmpty(x)){ # maybe and non-trivial
m<-length(x)
unmatched<-rep(TRUE,m) # refers to 'y'
for(i in 1:m){ # match 'x[[i]]' in 'y'
found<-FALSE
for(j in which(unmatched)){ # try all unmatched 'y[[i]]'
if(areTheSame(x[[i]],y[[j]])){ # matched
found<-T
unmatched[j]<-FALSE
break
} # end of if
} # end of for (j)
if(!found){ # not matched
res<-FALSE
break
} # end of if
} # end of for (i)
res<-res&&!any(unmatched)
} # end of if
return(res)
} # end of function
) # end of setMethod
# a 'logical' value answering the question is returned
## extraction
# multi extractor method for class 'undirectedEdge'
setMethod("[","undirectedEdge",function(x,i,j=NA,drop=NA) new("undirectedEdge",x@.Data[i]))
# an 'undirectedEdge' is extracted
# single extractor method for class 'undirectedEdge' gives an 'integer' object
# multi extractor method for class 'directedEdge'
setMethod("[","directedEdge",function(x,i,j=NA,drop=NA) new("directedEdge",x@.Data[i]))
# a 'directedEdge' is extracted
# single extractor method for class 'directedEdge'
setMethod("[[","directedEdge",function(x,i,j=NA,drop=NA) new("undirectedEdge",x@.Data[[i]]))
# an 'undirectedEdge' is extracted
# multiple extractor method for class 'edgeList'
setMethod("[","edgeList",function(x,i,j=NA,drop=NA)new("edgeList",x@.Data[i]))
# a sublist of edges is extracted
## typecasting
# typecasting method from 'vector' to 'undirectedEdge'
setAs("vector","undirectedEdge",function(from,to) new(to,from))
# just call the constructor with 'vector' input
# on the other hand, typecasting from "undirectedEdge" to "vector"
# is automatic and gives the '.Data' slot of the 'undirectedEdge' object
# typecasting method from 'vector' to 'directedEdge'
setAs("vector","directedEdge",function(from,to) new(to,from))
# just call the constructor with 'vector' input
# on the other hand, typecasting from 'directedEdge' to 'vector'
# is automatic and gives the '.Data' slot of the 'directedEdge' object
# typecasting from 'undirectedEdge' to 'directedEdge'
setAs("undirectedEdge","directedEdge",function(from,to) new(to,from))
# just call the constructor and exploit inheritance
# typecasting from 'directedEdge' to 'undirectedEdge'
setAs("directedEdge","undirectedEdge",function(from,to) new(to,from))
# just call the constructor and exploit inheritance
# typecasting from 'list' to 'edgeList'
setAs("list","edgeList",function(from,to) new(to,from))
# just call the constructor with 'list' input
# on the other hand, typecasting from "edgeList" to "list"
# is automatic and gives the '.Data' slot of the 'edgeList' object
## operators
# add operator for 'edgeList' and 'edge'
setMethod("+",c("edgeList","edge"),
function(e1,e2){
e1@.Data[[length(e1@.Data)+1]]<-e2
return(e1)
} # end of function
) # end of setMethod
# just add the edge to the list
setMethod("+",c("edge","edgeList"),function(e1,e2){e2+e1})
# and make the operation symmetric
# drop operator for 'edgeList' and 'edge' (not symmetric)
setMethod("-",c("edgeList","edge"),
function(e1,e2){
w<-which(as(unlist(lapply(e1,"areTheSame",y=e2)),"logical"))
if(length(w)==0){ # edge is not present in the list
return(e1)
} else{ # remove the first occurrence
return(e1[-w[1]])
} # end of if-else
} # end of function
) # end of setMethod
# look for the first copy of the edge in the list and remove it
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.