Nothing
######################################################################
#
# dataprep.R
#
# copyright (c) 2004, Carter T. Butts <buttsc@uci.edu>
# Last Modified 6/10/20
# Licensed under the GNU General Public License version 2 (June, 1991)
# or later.
#
# Part of the R/sna package
#
# This file contains various routines for preparing/preprocessing data
# for use with the sna package.
#
# Contents:
#
# add.isolates
# as.edgelist.sna
# as.sociomatrix.sna
# diag.remove
# ego.extract
# event2dichot
# gt
# gvectorize
# interval.graph
# is.edgelist.sna
# lower.tri.remove
# make.stochastic
# nties
# sr2css
# stackcount
# symmetrize
# upper.tri.remove
#
######################################################################
#add.isolates - Add isolates to one or more graphs
add.isolates<-function(dat,n,return.as.edgelist=FALSE){
dat<-as.edgelist.sna(dat)
if(is.list(dat))
return(lapply(dat,add.isolates,n=n,return.as.edgelist=return.as.edgelist))
#End pre-processing
attr(dat,"n")<-attr(dat,"n")+n
if(return.as.edgelist)
dat
else
as.sociomatrix(dat)
}
#Force the input into edgelist form. Network size, directedness, and vertex
#names are stored as attributes, since they cannot otherwise be included
as.edgelist.sna<-function(x, attrname=NULL, as.digraph=TRUE, suppress.diag=FALSE, force.bipartite=FALSE,...){
#In case of lists, process independently
# but this is tricky, since a 'network' object is also a list
if((is.list(x)&&!inherits(x,"network") )&&(!inherits(x,c("network","matrix.csr","matrix.csc", "matrix.ssr","matrix.ssc", "matrix.hb","data.frame")))){
# call this function on each element of the list and return as a list
return(lapply(x,as.edgelist.sna, attrname=attrname, as.digraph=as.digraph, suppress.diag=suppress.diag, force.bipartite=force.bipartite))
}
#Begin with network objects
if(inherits(x,"network")){
out<-as.matrix.network.edgelist(x,attrname=attrname,as.sna.edgelist=TRUE)
#This should be fine unless we have an old version of network (<1.7);
#here, we perform triage for old style objects.
if(!("as.sna.edgelist"%in%names(formals(as.matrix.network.edgelist)))){
if(NCOL(out)==2) #If needed, add edge values
out<-cbind(out,rep(1,NROW(out)))
if(suppress.diag&&has.loops(x))
out<-out[!(out[,1]==out[,2]),]
if((!is.directed(x))&&as.digraph){
if(has.loops(x)){
temp<-out[,1]==out[,2]
if(any(temp)){
temp2<-out[temp,]
out<-out[!temp,]
out<-rbind(out,out[,c(2,1,3)])
out<-rbind(out,temp2)
}else
out<-rbind(out,out[,c(2,1,3)])
}else
out<-rbind(out,out[,c(2,1,3)])
}
attr(out,"n")<-network.size(x)
attr(out,"vnames")<-network.vertex.names(x)
}
if(is.bipartite(x)) #Unneeded for new objects, but does no harm
attr(out,"bipartite")<-get.network.attribute(x,"bipartite")
else if(force.bipartite)
out<-as.edgelist.sna(out,attrname=attrname,as.digraph=as.digraph, suppress.diag=suppress.diag,force.bipartite=force.bipartite)
} else
#Not a network -- is this a sparse matrix (from SparseM)?
if(inherits(x,c("matrix.csr","matrix.csc","matrix.ssr","matrix.ssc", "matrix.hb"))){
requireNamespace("SparseM") #Need SparseM for this
if(force.bipartite||(!is.null(attr(x,"bipartite")))|| (x@dimension[1]!=x@dimension[2])){
nr<-x@dimension[1]
nc<-x@dimension[2]
val<-x@ra
if((!suppress.diag)&&inherits(x,c("matrix.ssr","matrix.ssc"))){
snd<-rep(1:nr,each=diff(x@ia))
rec<-nr+x@ja
out<-cbind(snd,rec,val)
out<-rbind(out,out[,c(2,1,3)])
}else{
snd<-switch(class(x)[1],
matrix.csr=rep(1:nr,each=diff(x@ia)),
matrix.csc=x@ja,
matrix.ssr=c(rep(1:nr,each=diff(x@ia)),x@ja),
matrix.ssc=c(x@ja,rep(1:nr,each=diff(x@ia)))
)
rec<-switch(class(x)[1],
matrix.csr=nr+x@ja,
matrix.csc=rep(nr+(1:nc),each=diff(x@ia)),
matrix.ssr=c(nr+x@ja,rep(1:n,each=diff(x@ia))),
matrix.ssc=c(rep(nr+(1:nc),each=diff(x@ia)),x@ja)
)
out<-cbind(snd,rec,val)
out<-rbind(out,out[,c(2,1,3)])
}
attr(out,"n")<-nr+nc
attr(out,"vnames")<-NULL #No dimnames for these objects
attr(out,"bipartite")<-nr
}else{
n<-x@dimension[1]
val<-x@ra
if((!suppress.diag)&&inherits(x,c("matrix.ssr","matrix.ssc"))){
snd<-rep(1:n,times=diff(x@ia))
rec<-x@ja
temp<-snd==rec
out<-cbind(snd,rec,val)
temp2<-out[temp,]
out<-out[!temp,]
out<-rbind(out,out[,c(2,1,3)])
out<-rbind(out,temp2)
}else{
snd<-switch(class(x)[1],
matrix.csr=rep(1:n,times=diff(x@ia)),
matrix.csc=x@ja,
matrix.ssr=c(rep(1:n,times=diff(x@ia)),x@ja),
matrix.ssc=c(x@ja,rep(1:n,times=diff(x@ia)))
)
rec<-switch(class(x)[1],
matrix.csr=x@ja,
matrix.csc=rep(1:n,times=diff(x@ia)),
matrix.ssr=c(x@ja,rep(1:n,times=diff(x@ia))),
matrix.ssc=c(rep(1:n,times=diff(x@ia)),x@ja)
)
out<-cbind(snd,rec,val)
if(suppress.diag)
out<-out[!(out[,1]==out[,2]),]
}
attr(out,"n")<-n
attr(out,"vnames")<-NULL #No dimnames for these objects
}
if(force.bipartite&&(is.null(attr(out,"bipartite"))))
out<-as.edgelist.sna(out,attrname=attrname,as.digraph=as.digraph, suppress.diag=suppress.diag,force.bipartite=force.bipartite)
} else
#Matrix or data frame case
if(is.matrix(x)||is.data.frame(x)){
if((NCOL(x)==3)&&(!is.null(attr(x,"n")))){ #Is this already an edgelist?
out<-x
if(force.bipartite&&(is.null(attr(out,"bipartite")))){ #Treat as bipartite
out[,2]<-out[,2]+attr(x,"n")
out<-rbind(out,out[,c(2,1,3)])
attr(out,"n")<-attr(x,"n")*2
attr(out,"bipartite")<-attr(x,"n")
if(!is.null(attr(x,"vnames")))
attr(out,"vnames")<-c(attr(x,"vnames"),attr(x,"vnames"))
else
attr(out,"vnames")<-NULL
}
}else if((NCOL(x)==2)&&(!is.null(attr(x,"n")))){ #Is this an edgelist w/out vals?
out<-cbind(x,rep(1,NROW(x)))
attr(out,"n")<-attr(x,"n")
attr(out,"bipartite")<-attr(x,"bipartite")
attr(out,"vnames")<-attr(x,"vnames")
if(force.bipartite&&(is.null(attr(out,"bipartite")))){ #Treat as bipartite
out[,2]<-out[,2]+attr(x,"n")
out<-rbind(out,out[,c(2,1,3)])
attr(out,"n")<-attr(x,"n")*2
attr(out,"bipartite")<-attr(x,"n")
if(!is.null(attr(x,"vnames")))
attr(out,"vnames")<-c(attr(x,"vnames"),attr(x,"vnames"))
else
attr(out,"vnames")<-NULL
}
}else if(force.bipartite||(!is.null(attr(x,"bipartite")))|| (NROW(x)!=NCOL(x))){ #Assume this is a bipartite graph
mask<-is.na(x)|(x!=0)
if(sum(mask)>0){
snd<-row(x)[mask]
rec<-NROW(x)+col(x)[mask]
val<-x[mask]
}else{
snd<-vector()
rec<-vector()
val<-vector()
}
out<-cbind(snd,rec,val)
out<-rbind(out,out[,c(2,1,3)])
attr(out,"n")<-NROW(x)+NCOL(x)
attr(out,"vnames")<-c(rownames(x),colnames(x))
attr(out,"bipartite")<-NROW(x)
}else{ #Assume this is an adjmat
mask<-is.na(x)|(x!=0)
snd<-row(x)[mask]
rec<-col(x)[mask]
val<-x[mask]
out<-cbind(snd,rec,val)
attr(out,"n")<-NROW(x)
attr(out,"vnames")<-rownames(x)
}
}else
#Array case
if(is.array(x)){
dx<-dim(x)
ldx<-length(dx)
if(ldx==2){ #Two-dimensional array
if((dx[2]==3)&&(!is.null(attr(x,"n")))){ #Is this already an edgelist?
out<-as.matrix(x)
attr(out,"n")<-attr(x,"n")
attr(out,"bipartite")<-attr(x,"bipartite")
attr(out,"vnames")<-attr(x,"vnames")
}
if((NCOL(x)==2)&&(!is.null(attr(x,"n")))){ #Is this an edgelist w/out vals?
out<-cbind(as.matrix(x),rep(1,NROW(x)))
attr(out,"n")<-attr(x,"n")
attr(out,"bipartite")<-attr(x,"bipartite")
attr(out,"vnames")<-attr(x,"vnames")
}else if(force.bipartite||(!is.null(attr(x,"bipartite")))|| (NROW(x)!=NCOL(x))){ #Assume this is a bipartite graph
mask<-is.na(x)|(x!=0)
if(sum(mask)>0){
snd<-row(x)[mask]
rec<-NROW(x)+col(x)[mask]
val<-x[mask]
}else{
sna<-vector()
rec<-vector()
val<-vector()
}
out<-cbind(snd,rec,val)
out<-rbind(out,out[,c(2,1,3)])
attr(out,"n")<-NROW(x)+NCOL(x)
attr(out,"vnames")<-c(dimnames(x)[[1]],dimnames(x)[[2]])
attr(out,"bipartite")<-NROW(x)
}else{ #Assume this is an adjmat
mask<-is.na(x)|(x!=0)
snd<-row(x)[mask]
rec<-col(x)[mask]
val<-x[mask]
out<-cbind(snd,rec,val)
attr(out,"n")<-NROW(x)
attr(out,"vnames")<-dimnames(x)[[1]]
}
if(force.bipartite&&(is.null(attr(out,"bipartite")))){ #Treat as bipartite
out[,2]<-out[,2]+attr(x,"n")
out<-rbind(out,out[,c(2,1,3)])
attr(out,"n")<-attr(x,"n")*2
attr(out,"bipartite")<-attr(x,"n")
if(!is.null(attr(x,"vnames")))
attr(out,"vnames")<-c(attr(x,"vnames"),attr(x,"vnames"))
else
attr(out,"vnames")<-NULL
}
}else if(ldx==3){ #Three-dimensional array
out<-unlist(apply(x,1,function(z){list(as.edgelist.sna(z, attrname=attrname,as.digraph=as.digraph,suppress.diag=suppress.diag,force.bipartite=force.bipartite))}),recursive=FALSE)
}else
stop("Array input to as.edgelist.sna must either be a proper edgelist, an adjacency matrix, or an adjacency array.\n")
}else{
stop("as.edgelist.sna input must be an adjacency matrix/array, edgelist matrix, network, or sparse matrix, or list thereof.\n")
}
#Return the result
out
}
#Force the input into sociomatrix form. This function includes an sna
#wrapper to the network function as.sociomatrix, for global happiness.
as.sociomatrix.sna<-function(x, attrname=NULL, simplify=TRUE, force.bipartite=FALSE){
#If passed a list, operate on each element
# but 'network' is also a list
if((is.list(x)&&!inherits(x,"network"))&&(!inherits(x, c("network","matrix.csr","matrix.csc", "matrix.ssr","matrix.ssc", "matrix.hb","data.frame")))){
g<-lapply(x,as.sociomatrix.sna,attrname=attrname,simplify=simplify, force.bipartite=force.bipartite)
#Otherwise, start with network
}else if(inherits(x,"network")){
g<-as.sociomatrix(x, attrname=attrname, simplify=simplify)
#Not a network -- is this a sparse matrix (from SparseM)?
}else if(inherits(x, c("matrix.csr","matrix.csc","matrix.ssr","matrix.ssc", "matrix.hb"))){
requireNamespace("SparseM") #Need SparseM for this
bip<-attr(x,"bipartite")
g<-as.matrix(x) #Coerce to matrix form, and pass on
attr(g,"bipartite")<-bip
}else{
#Coerce to adjacency matrix form -- by now, no other classes involved
n<-attr(x,"n") #Grab attributes before they get lost
bip<-attr(x,"bipartite")
vnam<-attr(x,"vnames")
if(is.array(x)&&(length(dim(x))==2)) #Quick diversion for 2-d arrays
x<-as.matrix(x)
if(is.data.frame(x)) #Coerce data frames to matrices
x<-as.matrix(x)
if(is.matrix(x)){
if((NCOL(x)%in%c(2,3))&&(!is.null(n))){ #sna edgelist
if(NCOL(x)==2)
x<-cbind(x,rep(1,NROW(x)))
g<-matrix(0,n,n)
if(NROW(x)>0)
g[x[,1:2,drop=FALSE]]<-x[,3]
rownames(g)<-vnam
colnames(g)<-vnam
}else if(force.bipartite||(!is.null(bip))||(NROW(x)!=NCOL(x))){ #Bipartite adjmat
nr<-NROW(x)
nc<-NCOL(x)
g<-matrix(0,nr+nc,nr+nc)
g[1:nr,(nr+1):(nr+nc)]<-x
g[(nr+1):(nr+nc),1:nr]<-t(x)
rownames(g)<-vnam
colnames(g)<-vnam
}else{ #Regular adjmat
g<-x
}
}else if(is.array(x)){ #If an array, test for type
if(length(dim(x))!=3)
stop("as.sociomatrix.sna input must be an adjacency matrix/array, network, data frame, sparse matrix, or list.")
if(force.bipartite||(!is.null(attr(x,"bipartite")))|| (dim(x)[2]!=dim(x)[3])){ #Bipartite stack
dx<-dim(x)
nr<-dx[2]
nc<-dx[3]
g<-array(0,dim=c(dx[1],nr+nc,nr+nc))
for(i in 1:dx[1]){
g[i,1:nr,(nr+1):(nr+nc)]<-x[i,,]
g[i,(nr+1):(nr+nc),1:nr]<-t(x[i,,])
}
}else{ #Adjacency stack
g<-x
}
}else{
stop("as.sociomatrix.sna input must be an adjacency matrix/array, network, or list.")
}
}
#Convert into the appropriate return format
if(is.list(g)){ #Collapse if needed
if(length(g)==1){
g<-g[[1]]
if((!simplify)&&(length(dim(g))==3)){ #Coerce to a list of matrices?
out<-list()
for(i in 1:dim(g)[1])
out[[i]]<-g[i,,]
}else{
out<-g
}
}else{
#Coerce to array form?
if(simplify){
dims<-sapply(g,dim)
if(is.list(dims)){ #Dims must not be of equal length
mats<-sapply(dims,length)
mats[mats==1]<-0
mats[mats==2]<-1
mats[mats==3]<-sapply(dims[mats==3],"[[",1)
mats<-cumsum(mats)
dims<-sapply(dims,"[",2)
}else{ #Dims are of equal length
if(NROW(dims)==3) #Determine number of matrices per entry
mats<-cumsum(dims[1,])
else
mats<-1:NCOL(dims)
dims<-dims[2,] #Get ncols
}
if((!any(is.null(dims)))&&(length(unique(dims))==1)&&(all(mats>0))){
out<-array(dim=c(mats[length(mats)],dims[1],dims[1]))
for(i in 1:length(mats))
out[(c(0,mats)[i]+1):(mats[i]),,]<-g[[i]]
}else
out<-g
}else
out<-g
}
}else{
if((!simplify)&&(length(dim(g))==3)){ #Coerce to a list of matrices?
out<-list()
for(i in 1:dim(g)[1])
out[[i]]<-g[i,,]
}else
out<-g
}
#Return the result
out
}
#diag.remove - NA the diagonals of adjacency matrices in a graph stack
diag.remove<-function(dat,remove.val=NA){
#Pre-process the raw input
dat<-as.sociomatrix.sna(dat)
if(is.list(dat))
return(lapply(dat,diag.remove,remove.val=remove.val))
#End pre-processing
if(length(dim(dat))>2){
d<-dat
for(i in 1:dim(dat)[1])
diag(d[i,,])<-remove.val
}
else{
d<-dat
diag(d)<-remove.val
}
d
}
#ego.extract - Extract ego nets from an input graph, returning them as a
#list of graphs.
ego.extract<-function(dat,ego=NULL,neighborhood=c("combined","in","out")){
#Pre-process the raw input
d<-as.sociomatrix.sna(dat)
if(is.list(d))
return(lapply(d,ego.extract,ego=ego,neighborhood=neighborhood))
else if(length(dim(dat))==3)
return(apply(d,1,ego.extract,ego=ego,neighborhood=neighborhood))
#End pre-processing
#Set input arguments
if(is.null(ego))
ego<-1:NROW(d)
neighborhood<-match.arg(neighborhood)
#Extract the selected ego nets
enet<-list()
for(i in 1:length(ego)){ #Walk the ego list
sel<-switch(neighborhood, #Grab the alters
"in"=(1:NROW(d))[d[,ego[i]]>0],
"out"=(1:NROW(d))[d[ego[i],]>0],
"combined"=(1:NROW(d))[(d[ego[i],]>0)|(d[,ego[i]]>0)]
)
if(length(sel)>0)
sel<-c(ego[i],sel[sel!=ego[i]]) #Force ego to be first
else
sel<-ego[i]
enet[[i]]<-d[sel,sel,drop=FALSE] #Perform the extraction
}
#Return the result
if(!is.null(rownames(d))) #Try to name the egos....
names(enet)<-rownames(d)[ego]
else if(!is.null(colnames(d)))
names(enet)<-colnames(d)[ego]
else
names(enet)<-ego
enet
}
#event2dichot - Convert an observed event matrix to a dichotomous matrix.
#Methods are quantile, mean, rquantile, rmean, cquantile, cmean, absolute, rank,
#rrank, and crank. Thresh specifies the cutoff, in terms of whatever method is
#used (if applicable).
event2dichot<-function(m,method="quantile",thresh=0.5,leq=FALSE){
#Pre-process the raw input
m<-as.sociomatrix.sna(m)
if(is.list(m))
return(lapply(m,event2dichot,method=method,thresh=thresh,leq=leq))
#End pre-processing
rnam<-rownames(m)
cnam<-colnames(m)
if(method=="quantile"){
q<-quantile(m,thresh,na.rm=TRUE, names=FALSE)
out<-as.numeric(m>q)
} else if(method=="rquantile"){
q<-quantile(m[1,],thresh,na.rm=TRUE, names=FALSE)
out<-as.numeric(m[1,]>q)
for(i in 2:dim(m)[1]){
q<-quantile(m[i,],thresh,na.rm=TRUE, names=FALSE)
out<-rbind(out,as.numeric(m[i,]>q))
}
} else if(method=="cquantile"){
q<-quantile(m[,1],thresh,na.rm=TRUE, names=FALSE)
out<-as.numeric(m[,1]>q)
for(i in 2:dim(m)[2]){
q<-quantile(m[,i],thresh,na.rm=TRUE, names=FALSE)
out<-cbind(out,as.numeric(m[,i]>q))
}
} else if(method=="mean"){
q<-mean(m)
out<-as.numeric(m>q)
} else if(method=="rmean"){
q<-mean(m[1,])
out<-as.numeric(m[1,]>q)
for(i in 2:dim(m)[1]){
q<-mean(m[i,])
out<-rbind(out,as.numeric(m[i,]>q))
}
} else if(method=="cmean"){
q<-mean(m[,1])
out<-as.numeric(m[,1]>q)
for(i in 2:dim(m)[2]){
q<-mean(m[,i])
out<-rbind(out,as.numeric(m[,i]>q))
}
} else if(method=="absolute"){
out<-as.numeric(m>thresh)
} else if(method=="rank"){
o<-order(m)
out<-as.numeric((max(o)-o+1)<thresh)
} else if(method=="rrank"){
o<-order(m[1,])
out<-as.numeric((max(o)-o+1)<thresh)
for(i in 2:dim(m)[1]){
o<-order(m[i,])
out<-rbind(out,as.numeric((max(o)-o+1)<thresh))
}
} else if(method=="crank"){
o<-order(m[,1])
out<-as.numeric((max(o)-o+1)<thresh)
for(i in 2:dim(m)[2]){
o<-order(m[,i])
out<-cbind(out,as.numeric((max(o)-o+1)<thresh))
}
}
if(leq==TRUE)
out<-1-out
if(is.null(dim(out))!=is.null(dim(m)))
out<-array(out,dim=dim(m))
else
if(dim(out)!=dim(m))
out<-array(out,dim=dim(m))
#Restore labels and return
rownames(out)<-rnam
colnames(out)<-cnam
out
}
#gt - "Graph transpose"; transposition of one or more networks
gt<-function(x, return.as.edgelist=FALSE){
if(return.as.edgelist){
#Pre-process the raw input
x<-as.edgelist.sna(x)
if(is.list(x))
return(lapply(x,gt,return.as.edgelist=TRUE))
#End pre-processing
n<-attr(x,"n")
vnames<-attr(x,"vnames")
bipartite<-attr(x,"bipartite")
x<-x[,c(2,1,3)]
attr(x,"n")<-n
attr(x,"vnames")<-vnames
attr(x,"bipartite")<-bipartite
x
}else{
#Pre-process the raw input
x<-as.sociomatrix.sna(x)
if(is.list(x))
return(lapply(x,gt,return.as.edgelist=FALSE))
#End pre-processing
if(length(dim(x))==3){
aperm(x,c(1,3,2))
}else
t(x)
}
}
#gvectorize - Vectorization of adjacency matrices
gvectorize<-function(mats,mode="digraph",diag=FALSE,censor.as.na=TRUE){
#Pre-process the raw input
mats<-as.sociomatrix.sna(mats)
if(is.list(mats))
return(lapply(mats,gvectorize,mode=mode,diag=diag, censor.as.na=censor.as.na))
#End pre-processing
#Build the input data structures
if(length(dim(mats))>2){
m<-dim(mats)[1]
n<-dim(mats)[2]
n<-dim(mats)[3]
d<-mats
}else{
m<-1
n<-dim(mats)[1]
o<-dim(mats)[2]
d<-array(dim=c(1,n,o))
d[1,,]<-mats
}
#If using NA censoring, turn unused parts of the matrices to NAs and vectorize
if(censor.as.na){
if(mode=="graph")
d<-upper.tri.remove(d)
if(!diag)
d<-diag.remove(d)
out<-apply(d,1,as.vector)
}else{ #Otherwise, vectorize only the useful parts
if(mode=="graph")
mask<-apply(d,1,lower.tri,diag=diag)
else{
if(diag)
mask<-matrix(TRUE,nrow=dim(d)[2]*dim(d)[3],ncol=dim(d)[1])
else
mask<-apply(d,1,function(z){diag(NROW(z))==0})
}
out<-apply(d,1,as.vector)
if(m==1)
out<-out[mask]
else
out<-matrix(out[mask],ncol=m)
}
out
}
#interval.graph - Construct one or more interval graphs (and exchangeability
#vectors) from a set of spells
interval.graph<-function(slist,type="simple",diag=FALSE){
#Note that each slice of slist must have one spell per row, with col 1 containing the spell type,
#col 2 containing the spell onset, and col 3 containing the spell termination. If there are multiple
#slices present, they must be indexed by the first dimension of the array.
#First, the preliminaries
o<-list()
m<-stackcount(slist) #Get the number of stacks
if(m==1){
d<-array(dim=c(m,dim(slist)[1],dim(slist)[2]))
d[1,,]<-slist
}else
d<-slist
ns<-dim(d)[2] #Get the number of spells
o$exchange.list<-d[,,1] #Exchange list is just the vector of spell types
#Now, for the graph itself...
o$graph<-array(dim=c(m,ns,ns))
for(i in 1:ns)
for(j in 1:ns)
o$graph[,i,j]<-switch(type,
simple=as.numeric((d[,i,2]<=d[,j,3])&(d[,i,3]>=d[,j,2])), #"Start before the end, end after the beginning"
overlap=pmax(pmin(d[,i,3],d[,j,3])-pmax(d[,i,2],d[,j,2]),0),
fracxy=pmax(pmin(d[,i,3],d[,j,3])-pmax(d[,i,2],d[,j,2]),0)/(d[,i,3]-d[,i,2]),
fracyx=pmax(pmin(d[,i,3],d[,j,3])-pmax(d[,i,2],d[,j,2]),0)/(d[,j,3]-d[,j,2]),
jntfrac=2*pmax(pmin(d[,i,3],d[,j,3])-pmax(d[,i,2],d[,j,2]),0)/(d[,i,3]-d[,i,2]+d[,j,3]-d[,j,2])
)
#Patch up those loose ends.
if(m==1)
o$graph<-o$graph[1,,]
if(!diag)
o$graph<-diag.remove(o$graph,remove.val=0)
#Return the data structure
o
}
#is.edgelist.sna - check to see if a data object is an sna edgelist
is.edgelist.sna<-function(x){
if(is.list(x)&&(!inherits(x,"network")))
return(sapply(x,is.edgelist.sna))
if(!inherits(x,c("matrix","array")))
FALSE
else if(length(dim(x))!=2)
FALSE
else if(dim(x)[2]!=3)
FALSE
else if(is.null(attr(x,"n")))
FALSE
else
TRUE
}
#lower.tri.remove - NA the lower triangles of adjacency matrices in a graph
#stack
lower.tri.remove<-function(dat,remove.val=NA){
#Pre-process the raw input
dat<-as.sociomatrix.sna(dat)
if(is.list(dat))
return(lapply(dat,lower.tri.remove,val=remove.val))
#End pre-processing
if(length(dim(dat))>2){
d<-dat
for(i in 1:dim(dat)[1]){
temp<-d[i,,]
temp[lower.tri(temp,diag=FALSE)]<-remove.val
d[i,,]<-temp
}
}
else{
d<-dat
d[lower.tri(d,diag=FALSE)]<-remove.val
}
d
}
#make.stochastic - Make a graph stack row, column, or row-column stochastic
make.stochastic<-function(dat,mode="rowcol",tol=0.005,maxiter=prod(dim(dat))*100,anneal.decay=0.01,errpow=1){
#Pre-process the raw input
dat<-as.sociomatrix.sna(dat)
if(is.list(dat))
return(lapply(dat,make.stochastic,mode=mode,tol=tol,maxiter=maxiter, anneal.decay=anneal.decay,errpow=errpow))
#End pre-processing
#Organize the data
m<-stackcount(dat)
if(m==1){
n<-dim(dat)[1]
o<-dim(dat)[2]
d<-array(dim=c(m,n,o))
d[1,,]<-dat
}else{
n<-dim(dat)[2]
o<-dim(dat)[3]
d<-dat
}
#Stochasticize
if(mode=="row"){
for(i in 1:m)
d[i,,]<-d[i,,]/t(sapply(apply(d[i,,],1,sum),rep,o))
}else if(mode=="col"){
for(i in 1:m)
d[i,,]<-d[i,,]/sapply(apply(d[i,,],2,sum),rep,n)
}else if(mode=="rowcol"){
for(i in 1:m){
f<-d[i,,]/t(sapply(apply(d[i,,],1,sum),rep,o)) #Seed with the row-stochastic form
f<-f/sapply(apply(f,2,sum),rep,n) #Col-stochasticize for good measure (sometimes this works)
edgelist<-cbind(rep(1:n,o),rep(1:o,rep(n,o)))
edgelist<-edgelist[d[i,,][edgelist]>0,] #Skip edges which are forced to be zero-valued
err<-sum(abs(apply(f,2,sum)-rep(1,o))^errpow,abs(apply(f,1,sum)-rep(1,n))^errpow)
iter<-0
while((err>(n+o)*tol)&(iter<maxiter)){ #Right now, use an annealer to find an approximate solution
edge<-sample(1:dim(edgelist)[1],1)
x<-edgelist[edge,1]
y<-edgelist[edge,2]
draw<-max(0,min(rnorm(1,f[x,y],d[i,x,y]/10),d[i,x,y]))
nerr<-err-abs(sum(f[x,])-1)^errpow-abs(sum(f[,y])-1)^errpow+abs(sum(f[x,][-y])+draw-1)^errpow+abs(sum(f[,y][-x])+draw-1)^errpow
if((nerr<err)|(runif(1,0,1)<exp(-anneal.decay*iter))){
f[x,y]<-draw
err<-nerr
}
iter<-iter+1
}
d[i,,]<-f
if(err>(n+o)*tol)
warning(paste("Annealer unable to reduce total error below apx",round(err,digits=7),"in matrix",i,". Hope that's OK....\n"))
}
}else if(mode=="total"){
for(i in 1:m)
d[i,,]<-d[i,,]/sum(d[i,,])
}
#Patch NaN values
d[is.nan(d)]<-0
#Return the output
if(m==1)
d[1,,]
else
d
}
#nties - Find the number of ties in a given graph or stack
nties<- function(dat,mode="digraph",diag=FALSE){
#Pre-process the raw input
dat<-as.sociomatrix.sna(dat)
if(is.list(dat))
return(lapply(dat,nties,mode=mode,diag=diag))
#End pre-processing
#Did someone send us a stack?
if(length(dim(dat))>2)
shiftit<-1
else
shiftit<-0
#Get size params
n<-dim(dat)[1+shiftit]
m<-dim(dat)[2+shiftit]
#Sanity check for hypergraphs
if(mode=="hgraph")
diag<-TRUE
#Get the initial count
count<-switch(mode,
digraph = n*n,
graph = (n*n-n)/2+n,
hgraph = n*m
)
#Modify for diag, if needed
if(!diag)
count<-count-n
#Return the needed info
if(shiftit)
rep(count,dim(dat)[1])
else
count
}
#sr2css - Convert a row-wise self-report matrix to a CSS matrix with missing
#observations.
sr2css<-function(net){
#Pre-process the raw input
dat<-as.sociomatrix.sna(net)
if(is.list(net))
return(lapply(net))
#End pre-processing
n<-dim(net)[1]
css<-array(dim=c(n,n,n))
for(i in 1:n){
css[i,,]<-NA
css[i,i,]<-net[i,]
}
css
}
#stackcount -How many matrices in a given stack?
stackcount<-function(d){
#Pre-process the raw input
d<-as.edgelist.sna(d)
#End pre-processing
if(is.list(d))
length(d)
else
1
}
#symmetrize - Convert a graph or graph stack to a symmetric form. Current rules
#for symmetrizing include "upper" and "lower" diagonals, "weak" connectedness
#rule, and a "strong" connectedness rule. If return.as.edgelist=TRUE, the
#data is processed and returned in sna edgelist form.
symmetrize<-function(mats,rule="weak",return.as.edgelist=FALSE){
if(!return.as.edgelist){ #Adjacency matrix form
#Pre-process the raw input
mats<-as.sociomatrix.sna(mats)
if(is.list(mats))
return(lapply(mats,symmetrize,rule=rule, return.as.edgelist=return.as.edgelist))
#End pre-processing
#Build the input data structures
if(length(dim(mats))>2){
m<-dim(mats)[1]
n<-dim(mats)[2]
o<-dim(mats)[3]
d<-mats
}else{
m<-1
n<-dim(mats)[1]
o<-dim(mats)[2]
d<-array(dim=c(1,n,o))
d[1,,]<-mats
}
#Apply the symmetry rule
for(i in 1:m){
if(rule=="upper"){
d[i,,][lower.tri(d[i,,])]<-t(d[i,,])[lower.tri(d[i,,])]
}else if(rule=="lower"){
d[i,,][upper.tri(d[i,,])]<-t(d[i,,])[upper.tri(d[i,,])]
}else if(rule=="weak"){
d[i,,]<-matrix(as.numeric(d[i,,]|t(d[i,,])),nrow=n,ncol=o)
}else if(rule=="strong"){
d[i,,]<-matrix(as.numeric(d[i,,]&t(d[i,,])),nrow=n,ncol=o)
}
}
#Return the symmetrized matrix
if(m==1)
out<-d[1,,]
else
out<-d
out
}else{ #Edgelist matrix form
#Pre-process the raw input
mats<-as.edgelist.sna(mats)
if(is.list(mats))
return(lapply(mats,symmetrize,rule=rule, return.as.edgelist=return.as.edgelist))
#End pre-processing
n<-attr(mats,"n")
vn<-attr(mats,"vnames")
bip<-attr(mats,"bipartite")
if(!is.null(bip))
return(mats) #Return unaltered if bipartite
#Apply the symmetry rule
if(rule=="upper"){
loops<-mats[mats[,1]==mats[,2],,drop=FALSE]
upedge<-mats[mats[,1]<mats[,2],,drop=FALSE]
mats<-rbind(upedge,upedge[,c(2,1,3)],loops)
}else if(rule=="lower"){
loops<-mats[mats[,1]==mats[,2],,drop=FALSE]
loedge<-mats[mats[,1]>mats[,2],,drop=FALSE]
mats<-rbind(loedge,loedge[,c(2,1,3)],loops)
}else if(rule=="weak"){
isloop<-mats[,1]==mats[,2]
loops<-mats[isloop,,drop=FALSE]
mats<-mats[!isloop,,drop=FALSE]
dc<-.C("dyadcode_R",as.double(mats),as.integer(n),as.integer(NROW(mats)), dc=as.double(rep(0,NROW(mats))),PACKAGE="sna",NAOK=TRUE)$dc
isdup<-duplicated(dc)
mats<-mats[!isdup,,drop=FALSE]
mats<-rbind(mats,mats[,c(2,1,3)],loops)
}else if(rule=="strong"){
isloop<-mats[,1]==mats[,2]
loops<-mats[isloop,,drop=FALSE]
mats<-mats[!isloop,,drop=FALSE]
dc<-.C("dyadcode_R",as.double(mats),as.integer(n),as.integer(NROW(mats)), dc=as.double(rep(0,NROW(mats))),PACKAGE="sna",NAOK=TRUE)$dc
isdup<-duplicated(dc)
mats<-mats[isdup,,drop=FALSE]
mats<-rbind(mats,mats[,c(2,1,3)],loops)
}
#Patch up the attributes and return
attr(mats,"n")<-n
attr(mats,"vnames")<-vn
mats
}
}
#upper.tri.remove - NA the upper triangles of adjacency matrices in a graph
#stack
upper.tri.remove<-function(dat,remove.val=NA){
#Pre-process the raw input
dat<-as.sociomatrix.sna(dat)
if(is.list(dat))
return(lapply(dat,upper.tri.remove,remove.val=remove.val))
#End pre-processing
if(length(dim(dat))>2){
d<-dat
for(i in 1:dim(dat)[1]){
temp<-d[i,,]
temp[upper.tri(temp,diag=FALSE)]<-remove.val
d[i,,]<-temp
}
}
else{
d<-dat
d[upper.tri(d,diag=FALSE)]<-remove.val
}
d
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.