1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
cStatus<-list(
blockTypes=c("nul", "com", "cdo", "rdo", "cfn", "rfn", "reg", "cre", "rre", "avg", "dnc"),
regFuns=c("max","sum","mean"),
homFuns=c("ss", "ad", "bll"),
implementedApproaches=c("hom", "bin","val")
# ,maxBlockTypes=as.integer(10)
)
# zgornje spremenljivke morajo biti enake kot v C-ju (blockmodeling.c)
allInDimEqual<-function(arr,d)all(apply(arr,d,function(x){x<-as.vector(x);all(x==x[1])}))
clu2parArr<-function(clu){
if(!is.list(clu))clu<-list(clu,clu)
nrc<-sapply(clu,length)
clu<-lapply(clu,function(x)as.integer(as.factor(x)))
nUnitsInRCclu<-lapply(clu,function(x)as.integer(table(x)))
nRCclu<-sapply(nUnitsInRCclu,length)
rowParArr<-matrix(as.integer(0),nrow=nrc[1],ncol=nRCclu[1])
for(i in clu[[1]]){
rowParArr[1:nUnitsInRCclu[[1]][i],i]<-as.integer(which(clu[[1]]==i)-1)
}
colParArr<-matrix(as.integer(0),nrow=nrc[2],ncol=nRCclu[2])
for(i in clu[[2]]){
colParArr[1:nUnitsInRCclu[[2]][i],i]<-as.integer(which(clu[[2]]==i)-1)
}
return(list(rowParArr=rowParArr,colParArr=colParArr,nUnitsInRCclu=nUnitsInRCclu, nRCclu=nRCclu, nrc=nrc))
}
parArr2clu<-function(nUnitsRowClu, nUnitsColClu, rowParArr, colParArr, nColClus=NULL, nRowClus=NULL){
clu<-list(parArrOne2clu(nUnitsClu=nUnitsRowClu, parArr=rowParArr, nClus=nRowClus),parArrOne2clu(nUnitsClu=nUnitsColClu, parArr=colParArr, nClus=nColClus))
}
parArrOne2clu<-function(nUnitsClu, parArr,nClus=NULL){
if(is.null(nClus)){
nClus<-dim(parArr)[2]
} else {
if(nClus!=dim(parArr)[2]) warning("Number of clusters and dimmension of the partition array do not match")
}
n<-sum(nUnitsClu)
clu<-rep(NA,n)
for(i in 1:nClus){
clu[parArr[(1:nUnitsClu[i]),i]+1]<-i
}
return(clu)
}
IMaddNames<-function(IM){
array(factor(IM+1,labels=cStatus$blockTypes,levels=1:length(cStatus$blockTypes)),dim=dim(IM))
}
formatPreSpecM<-function(preSpecMorg,dB,blocks){
if(is.null(preSpecMorg)){
preSpecM <- array(as.double(NA),dim=dB)
} else if (is.vector(preSpecMorg)){
if(length(preSpecMorg)==1){
preSpecM <- array(as.double(preSpecMorg),dim=dB)
} else if(length(preSpecMorg)==dB[2]){
preSpecM <- array(as.double(NA),dim=dB)
for(i in 1:dB[2]){
preSpecM[,i,,]<-as.double(preSpecMorg[i])
}
} else if((dB[2]==1) & (length(preSpecMorg)==dB[1]) & allInDimEqual(blocks,1)){
preSpecM <- array(as.double(NA),dim=dB)
for(i in 1:dB[1]){
preSpecM[i,,,]<-as.double(preSpecMorg[i])
}
} else stop("'",deparse(substitute(preSpecMorg)),"' is a vector with unexpected length")
} else if(is.array(preSpecMorg)){
preSpecM <- array(as.double(preSpecMorg),dim=dim(preSpecMorg))
if(any(dim(preSpecM)!=dB)){
stop("dimensions of '",deparse(substitute(preSpecMorg)),"' and 'blocks' do not match")
}
}
return(preSpecM)
}
computeCombWeights<-function(combWeights, dB, blocks, relWeights, posWeights, blockTypeWeights){
if(!is.null(combWeights)){
if(all(dim(combWeights)==dB)){
combWeights<-array(as.double(combWeights),dim=dim(combWeights))
return(combWeights)
}
warning("Dimmensions of the combWeights does not match the dimmensions of blocks!\nIt will not be used!\nIf possible it will be computed using other weights!")
}
combWeights<-array(as.double(1),dim=dB)
relWeights<-as.double(relWeights)
if(length(relWeights)!=dB[2]){
if(length(relWeights)==1) relWeights<-rep(relWeights,dB[2]) else stop("To relWeights should have length equal to the number of relations!")
}
for(i in 1:dB[2]){
combWeights[,i,,]<-combWeights[,i,,]*relWeights[i]
}
if(all(dim(posWeights)!=dB[3:4])){
if(length(posWeights)==1) posWeights<-array(posWeights,dim=dB[3:4]) else stop("To posWeights should have the same dimensions as block image!")
}
posWeights<-array(as.double(posWeights), dim=dim(posWeights))
for(i in 1:dB[3]){
for(j in 1:dB[4]){
combWeights[,,i,j]<-combWeights[,,i,j]*posWeights[i,j]
}
}
if(!(is.numeric(blockTypeWeights)&all(names(blockTypeWeights)%in%cStatus$blockTypes))) stop("blockTypeWeights must be a numeric named vector with names from: ", paste(cStatus$blockTypes, collapse=", "))
for(i in names(blockTypeWeights)){
tWhich <- blocks==i
tWhich[is.na(tWhich)]<-FALSE
combWeights[tWhich]<-blockTypeWeights[i]* combWeights[tWhich]
}
return(combWeights)
}
formatUsePreSpecM<-function(usePreSpecMorg,preSpecM,dB,blocks){
if(is.null(usePreSpecMorg)){
usePreSpecM<- !is.na(preSpecM)
}else if(is.vector(usePreSpecMorg)){
if(length(usePreSpecMorg)==dB[2]){
usePreSpecM <- array(as.integer(NA),dim=dB)
for(i in 1:dB[2]){
usePreSpecM[,i,,]<-as.integer(usePreSpecMorg[i])
}
} else if((dB[2]==1) & (length(usePreSpecMorg)==dB[1]) & allInDimEqual(blocks,1)){
usePreSpecM <- array(as.integer(NA),dim=dB)
for(i in 1:dB[1]){
usePreSpecM[i,,,]<-as.integer(usePreSpecMorg[i])
}
} else stop("'",deparse(substitute(usePreSpecM)),"' is a vector with unexpected length")
} else if(is.array(usePreSpecMorg)){
if(any(dim(usePreSpecMorg)!=dB)){
stop("dimensions of '",deparse(substitute(usePreSpecM)),"' and 'blocks' do not match")
}
usePreSpecM <- array(as.integer(usePreSpecMorg),dim=dim(usePreSpecMorg))
}
return(usePreSpecM)
}
|
