[med-svn] [r-cran-blockmodeler] 01/02: Imported Upstream version 0.1.8
Michael Crusoe
misterc-guest at moszumanska.debian.org
Tue Feb 17 02:25:16 UTC 2015
This is an automated email from the git hooks/post-receive script.
misterc-guest pushed a commit to branch master
in repository r-cran-blockmodeler.
commit f5ea354e4573be0d62bfe7d2da71da4c1f19f760
Author: Michael R. Crusoe <mcrusoe at msu.edu>
Date: Mon Feb 16 19:47:58 2015 -0500
Imported Upstream version 0.1.8
---
CHANGES | 83 ++++
DESCRIPTION | 22 +
NAMESPACE | 32 ++
R/IM.R | 5 +
R/REGE.FC.R | 64 +++
R/REGE.FC.ow.R | 68 +++
R/REGE.R | 48 +++
R/REGE.ow.R | 54 +++
R/REGE_for.R | 523 ++++++++++++++++++++++
R/ad.R | 3 +
R/check.these.par.R | 48 +++
R/clu.R | 7 +
R/crand.R | 10 +
R/crand2.R | 11 +
R/crit.fun.R | 47 ++
R/err.R | 5 +
R/find.cut.R | 41 ++
R/find.m.R | 81 ++++
R/find.m2.R | 42 ++
R/formatA.R | 5 +
R/fun.by.blocks.R | 3 +
R/fun.by.blocks.default.R | 32 ++
R/fun.by.blocks.opt.more.par.R | 13 +
R/gen.crit.fun.R | 692 ++++++++++++++++++++++++++++++
R/gen.opt.par.R | 265 ++++++++++++
R/genRandomPar.R | 81 ++++
R/genRandomParGroups.R | 90 ++++
R/gplot.R | 19 +
R/ircNorm.R | 22 +
R/loadmatrix.R | 21 +
R/loadnetwork.R | 106 +++++
R/loadnetwork2.R | 85 ++++
R/loadpajek.R | 73 ++++
R/loadvector.R | 8 +
R/loadvector2.R | 11 +
R/mean.max.col.R | 3 +
R/mean.max.row.R | 3 +
R/meanpos.R | 3 +
R/nkpar.R | 6 +
R/nkpartitions.R | 83 ++++
R/one2two.R | 11 +
R/opt.par.R | 56 +++
R/opt.random.par.R | 161 +++++++
R/opt.these.par.R | 131 ++++++
R/parOKgroups.R | 7 +
R/plot.check.these.par.R | 15 +
R/plot.crit.fun.R | 10 +
R/plot.mat.R | 239 +++++++++++
R/plot.mat.nm.R | 20 +
R/plot.opt.more.par.R | 15 +
R/plot.opt.more.par.mode.R | 15 +
R/plot.opt.par.R | 15 +
R/plot.opt.par.mode.R | 15 +
R/rand.R | 7 +
R/rand2.R | 7 +
R/recode.R | 10 +
R/reorderImage.R | 5 +
R/savecluster.R | 8 +
R/savematrix.R | 47 ++
R/savenetwork.R | 77 ++++
R/savepajek.R | 69 +++
R/savevector.R | 8 +
R/sedist.R | 72 ++++
R/ss.R | 3 +
R/sumpos.R | 3 +
R/two2one.R | 16 +
R/useneg.R | 3 +
R/usepos.R | 3 +
man/Pajek.Rd | 81 ++++
man/REGE.Rd | 117 +++++
man/blockmodeling-package.Rd | 86 ++++
man/check.these.par.Rd | 72 ++++
man/clu.Rd | 62 +++
man/crit.fun.Rd | 135 ++++++
man/find.m.Rd | 55 +++
man/formatA.Rd | 27 ++
man/fun.by.blocks.Rd | 75 ++++
man/genRandomPar.Rd | 32 ++
man/gplot1.Rd | 44 ++
man/ircNorm.Rd | 34 ++
man/nkpartitions.Rd | 44 ++
man/opt.par.Rd | 93 ++++
man/opt.random.par.Rd | 136 ++++++
man/plot.mat.Rd | 167 +++++++
man/rand.Rd | 27 ++
man/recode.Rd | 28 ++
man/reorderImage.Rd | 32 ++
man/sedist.Rd | 59 +++
man/ss.Rd | 17 +
man/two2one.Rd | 54 +++
src/REGD_NE_R.f90 | 117 +++++
src/REGD_OW_NE_R.f90 | 132 ++++++
src/REGD_OW_R.f90 | 104 +++++
src/REGD_R.f90 | 88 ++++
src/REGE_NE_R.f90 | 116 +++++
src/REGE_NM_DIAG_R.f90 | 76 ++++
src/REGE_NM_NE_R.f90 | 115 +++++
src/REGE_NM_R.f90 | 73 ++++
src/REGE_OWNM_DIAG_R.f90 | 82 ++++
src/REGE_OWNM_NE_R.f90 | 121 ++++++
src/REGE_OWNM_R.f90 | 79 ++++
src/REGE_OW_NE_R.f90 | 121 ++++++
src/REGE_OW_R.f90 | 81 ++++
src/REGE_R.f90 | 74 ++++
src/opt_par_ss_com.f90 | 379 ++++++++++++++++
src/opt_par_ss_com_twoMode.f90 | 529 +++++++++++++++++++++++
src/opt_par_ss_com_twoMode_forMoreRel.f90 | 579 +++++++++++++++++++++++++
src/ss_blocks.f90 | 106 +++++
108 files changed, 8315 insertions(+)
diff --git a/CHANGES b/CHANGES
new file mode 100644
index 0000000..14f0875
--- /dev/null
+++ b/CHANGES
@@ -0,0 +1,83 @@
+Name: blockmodeling
+Title: An R package for Generalized and classical blockmodeling of valued networks
+Version: 0.1.7
+
+February 8, 2009:
+A bug fixed in savevector, savenetwork and savematrix. Now these functions should aslo work on non-windows systems.
+
+December 1, 2008:
+Several bugs fixed (in functions: gen.crit.fun, plot.mat, loadnetwork)
+
+November 20, 2008:
+A minor bug in savenetwork fixed.
+
+November 14, 2008:
+New version: 0.1.7
+Severali minor bugs fixed.
+Pacakged prepared for CRAN
+
+September 4, 2008:
+Bug in the fortran code for two-mode networks fixed.
+Optimization of partitions for sum of squares blockmodeling for structural equivalence now implemeted in FORTRAN (runs much faster) also for two-mode multirelational networks.
+
+August 2, 2008:
+New version: 0.1.6
+Severali minor bugs fixed.
+Optimization of partitions for sum of squares blockmodeling for structural equivalence now implemeted in FORTRAN (runs much faster) also for two-mode networks.
+
+May 18, 2008:
+In helpfile for function "crit.fun" had such description for the argument "FUN": "(default = "max") Function f used in row-f-regular, column-f-regular, and f-regular blocks. Not used in binary approach. For multi-relational networks, it can be a vector of such character strings." The last sentence was not yet implemetned (I guess I missed it) - now it is.
+
+May 17, 2008:
+Function "gen.opt.par" (a function used whenever we are optimizing a partition) modified in such a way that it allows us to specify a function "parOK" (and it's parameters) which can check if each partition is allowed prior to its evaluation. Very useful if we want forbid some kind of partition (e.g. - boys can not mix with girls).
+
+May 6, 2008:
+A bug in the way partitions were generated in function "opt.random.par" fixed.
+Function "opt.random.par" modified in a way that not it is possible to specify a function that will generate random partitions.
+New function "genRandomPar" for gereration of random partition added (mainly ported from "opt.random.par").
+
+January 26, 2008:
+New version: 0.1.5
+Several minor bugs fixed.
+New functionality - for homogeneity blockmodeling, it is now possible to specify prespecified central values as fixes, as a minimal value that the central value can be or as a maximal value that central value can be. For now, specification has to be in the from of of an 3d array. With the correct specification of BLOCKS, BLOCKS.CV and CV.use, we can have several alternative centar values for the same block types. E.g. we can have to complete blocks with different central values (e.g. 3 [...]
+
+January 2, 2008:
+Several minor bugs fixed.
+New function "loadpajek"
+February 8, 2007:
+A new function "partitions" added that extracts all "best" partitions found by functions such as "opt.par", "opt.these.par", "opt.random.par" and "check.these.par".
+January 31, 2007:
+Several minor bugs fixed.
+January 25, 2007:
+Methods for finding random partitions from Pajek incorporated. Bug in �gen.opt.par� fixed.
+January 16, 2007:
+Several bugs fixed.
+December 8, 2006:
+Several bugs fixed.
+November 29, 2006:
+Several bugs fixed and new function "reorderImage" added.
+October 20, 2006:
+Several bugs fixed.
+October 11, 2006:
+New version: 0.1.4
+Several bugs fixed.
+3 versions of row- and column-dominant blocks for homogeneity blockmodeling implemented.
+Multirelational networks now supported.
+Support for using a combination of several approaches to blockmodeling.
+Option to analyze row and column normalized versions of the original network instead of the original one.
+Some new support functions.
+Many slow functions (opt.random.par, opt.these.par, check.these.par) changed to that if Esc presed during the execution, most of the results are saved.
+
+July 5, 2006:
+Several bugs fixed.
+Different default behavior of "imp" - implicit approach.
+April 11, 2006:
+Several bugs in �opt.random.par� and a few in �gen.crit.fun� concerning two-mode networks fixed.
+April 8, 2006:
+A several bugs fixed in �gen.crit.fun�, a function used by all functions that compute inconsistencies for blockmodels.
+April 3, 2006:
+A bug fixed in fortran code used by �crit.fun� and �check.these.par� for Sum of squares blockmodeling with only complete blocks.
+A bug fixed in �sedist�
+March 23, 2006:
+A bug fixed in �plot.mat�
+
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..7a4bdf8
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,22 @@
+Package: blockmodeling
+Type: Package
+Title: An R package for Generalized and classical blockmodeling of
+ valued networks
+Version: 0.1.8
+Date: 2010-01-12
+Imports: stats
+Suggests: sna, Matrix
+Author: Ales Ziberna
+Maintainer: Ales Ziberna <ales.ziberna at gmail.com>
+Description: The package is primarly ment as an implementation of
+ Generalized blockmodeling for valued networks. In addition,
+ measurese of similarity or dissimilarity based on structural
+ equivalence and regular equivalence (REGE algorithem) can be
+ computed and partitioned matrices can be ploted.
+License: GPL (>= 2)
+Encoding: UTF-8
+Repository: CRAN
+Repository/R-Forge/Project: blockmodeling
+Repository/R-Forge/Revision: 26
+Date/Publication: 2010-01-13 15:43:51
+Packaged: 2010-01-12 21:10:55 UTC; rforge
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..0c30226
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,32 @@
+useDynLib(blockmodeling)
+
+#importFrom(sna, gplot)
+
+export(check.these.par, crit.fun, opt.par, opt.random.par, opt.these.par) #basic front end functions
+export(genRandomPar)
+export(plot.mat,plot.mat.nm)
+#export(plot.check.these.par, plot.crit.fun, plot.opt.more.par, plot.opt.more.par.mode, plot.opt.par, plot.opt.par.mode)
+export(sedist)
+export(rand, rand2, crand, crand2)
+export(nkpar, nkpartitions) #recieved my mail
+export(gplot1, gplot2)
+export(find.m, find.m2, find.cut)
+export(ss, ad)
+export(ircNorm)
+export(clu, err, IM, reorderImage, partitions)
+export(one2two, two2one)
+export(recode, formatA)
+export(fun.by.blocks)
+export(loadnetwork, loadnetwork2, loadmatrix, loadvector, loadvector2, loadpajek, savematrix, savenetwork, savevector, savecluster, savepajek)
+export(REGD.for, REGD.ow.for, REGE, REGE.for, REGE.nm.for, REGE.nm.diag.for, REGE.ow.for, REGE.ownm.for, REGE.ownm.diag.for, REGE.ow, REGE.FC, REGE.FC.ow, REGD.ne.for, REGD.ow.ne.for,REGE.ne.for, REGE.nm.ne.for, REGE.ow.ne.for, REGE.ownm.ne.for) #REGE - some White's
+
+S3method(plot,check.these.par)
+S3method(plot,crit.fun)
+S3method(plot,mat)
+S3method(plot,opt.more.par)
+S3method(plot,opt.more.par.mode)
+S3method(plot,opt.par)
+S3method(plot,opt.par.mode)
+
+S3method(fun.by.blocks,opt.more.par)
+S3method(fun.by.blocks,default)
diff --git a/R/IM.R b/R/IM.R
new file mode 100644
index 0000000..4835c8e
--- /dev/null
+++ b/R/IM.R
@@ -0,0 +1,5 @@
+"IM" <-
+function(res,which=1,...){
+ res$best[[which]]$IM
+}
+
diff --git a/R/REGE.FC.R b/R/REGE.FC.R
new file mode 100644
index 0000000..d92e35a
--- /dev/null
+++ b/R/REGE.FC.R
@@ -0,0 +1,64 @@
+"REGE.FC" <-
+function(M,E=1,iter=3,until.change=TRUE,use.diag=TRUE,normE=FALSE){
+ n<-dim(M)[1]
+ if(n!=dim(M)[2]) stop("M must be a 1-mode matrix")
+ if(!use.diag)diag(M)<-0
+ Eall<-array(NA,dim=c(n,n,iter+1)) #An array of 'iter' similiaritie matrices
+ Eall[,,1]<-E
+ B<-(M+t(M))>0
+ Match<-array(NA,dim=rep(n,4))
+ Max<-array(NA,dim=rep(n,4))
+ for(i in 2:n){
+ for(j in 1:(i-1)){
+ for(k in 1:n){
+ for(m in 1:n){
+ Match[i,j,k,m]<-min(M[i,k],M[j,m]) + min(M[k,i],M[m,j])
+ Match[j,i,k,m] <- min(M[j,k],M[i,m]) + min(M[k,j],M[m,i])#/max(1,(max(M[i,k],M[j,m]) + max(M[k,i],M[m,j])+max(M[j,k],M[i,m]) + max(M[k,j],M[m,i])))
+ Max[i,j,k,m]<-max(M[i,k],M[j,m]) + max(M[k,i],M[m,j])
+ Max[j,i,k,m]<-max(M[j,k],M[i,m]) + max(M[k,j],M[m,i])
+ }
+ }
+ }
+ }
+
+ for(it in 1:iter){
+ for(i in 2:n){
+ for(j in 1:(i-1)){
+ num<-0
+ den<-0
+ #sim<-0
+ for(k in 1:n){
+ #sim<-max(Eall[k,,it]*Match[i,j,k,])
+ ms1<-(Eall[k,,it]*Match[i,j,k,])
+ Maxms1<-max(ms1)
+ Maxm1<-which(ms1==Maxms1)
+ ms2<-(Eall[k,,it]*Match[j,i,k,])
+ Maxms2<-max(ms2)
+ Maxm2<-which(ms2==Maxms2)
+ num<-num+Maxms1+Maxms2
+ den<-den+B[i,k]*min(Max[i,j,k,Maxm1])+B[j,k]*min(Max[j,i,k,Maxm2])
+ #if(i==2&j==1)cat("num = ", num,", den = ",den,", k = ",k,", Maxm1 = ",Maxm1,", ms1 = ",ms1,", Maxm2 = ",Maxm2,", ms2 = ",ms2,"\n")
+ }
+ #cat("iter=",it,", i=",i,", j=",j,", num=",num,", den=", den,"\n")
+ if(den!=0) {
+ Eall[j,i,it+1]<-Eall[i,j,it+1]<-num/den
+ } else Eall[j,i,it+1]<-Eall[i,j,it+1]<-1
+ }
+ }
+ diag(Eall[,,it+1])<-1
+ if(normE){
+ diag(Eall[,,it+1])<-0
+ Eall[,,it+1]<-Eall[,,it+1]/sqrt(outer(apply(Eall[,,it+1],1,sum), apply(Eall[,,it+1],2,sum)))
+ diag(Eall[,,it+1])<-max(Eall[,,it+1])
+ }
+ if(until.change & all(Eall[,,it]==Eall[,,it+1])){
+ Eall<-Eall[,,1:(it+1)]
+ break
+ }
+ }
+ itnames<-0:(it)
+ itnames[1]<-"initial"
+ itnames[it+1]<-"final"
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],itnames)
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter,use.diag=use.diag))
+}
diff --git a/R/REGE.FC.ow.R b/R/REGE.FC.ow.R
new file mode 100644
index 0000000..df55748
--- /dev/null
+++ b/R/REGE.FC.ow.R
@@ -0,0 +1,68 @@
+"REGE.FC.ow" <-
+function(M,E=1,iter=3,until.change=TRUE,use.diag=TRUE,normE=FALSE){
+ n<-dim(M)[1]
+ if(n!=dim(M)[2]) stop("M must be a 1-mode matrix")
+ if(length(dim(M))==2)M<-array(M,dim=c(n,n,1))
+ nr<-dim(M)[3]
+ if(!use.diag){for(ir in 1:nr) diag(M[,,ir])<-0}
+
+ Eall<-array(NA,dim=c(n,n,iter+1)) #An array of 'iter' similiaritie matrices
+ Eall[,,1]<-E
+ for(it in 1:iter){
+ for(i in 2:n){
+ for(j in 1:(i-1)){
+ num<-0
+ den<-0
+ for(ir in 1:nr){
+ for(k in 1:n){
+ if(M[i,k,ir]>0) {
+ mins<-Eall[k,,it]*pmin(M[i,k,ir],M[j,,ir])
+ num<-num+max(mins)
+ den<-den+min(pmax(M[i,k,ir],M[j,which(mins==max(mins)),ir]))
+ #cat("M[i,k]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n")
+ }
+
+ if(M[k,i,ir]>0) {
+ mins<-Eall[k,,it]*pmin(M[k,i,ir],M[,j,ir])
+ num<-num+max(mins)
+ den<-den+min(pmax(M[k,i,ir],M[which(mins==max(mins)),j,ir]))
+ #cat("M[k,i]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n")
+ }
+
+ if(M[j,k,ir]>0) {
+ mins<-Eall[k,,it]*pmin(M[j,k,ir],M[i,,ir])
+ num<-num+max(mins)
+ den<-den+min(pmax(M[j,k,ir],M[i,which(mins==max(mins)),ir]))
+ #cat("M[j,k]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n")
+ }
+
+ if(M[k,j,ir]>0) {
+ mins<-Eall[k,,it]*pmin(M[k,j,ir],M[,i,ir])
+ num<-num+max(mins)
+ den<-den+min(pmax(M[k,j,ir],M[which(mins==max(mins)),i,ir]))
+ #cat("M[k,j]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n")
+ }
+ }
+ }
+ if(den!=0) {
+ Eall[j,i,it+1]<-Eall[i,j,it+1]<-num/den
+ } else Eall[j,i,it+1]<-Eall[i,j,it+1]<-1
+ diag(Eall[,,it+1])<-1
+ }
+ }
+ if(normE){
+ diag(Eall[,,it+1])<-0
+ Eall[,,it+1]<-Eall[,,it+1]/sqrt(outer(apply(Eall[,,it+1],1,sum), apply(Eall[,,it+1],2,sum)))
+ diag(Eall[,,it+1])<-max(Eall[,,it+1])
+ }
+ if(until.change & all(Eall[,,it]==Eall[,,it+1])){
+ Eall<-Eall[,,1:(it+1)]
+ break
+ }
+ }
+ itnames<-0:(it)
+ itnames[1]<-"initial"
+ itnames[it+1]<-"final"
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],itnames)
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter,use.diag=use.diag))
+}
diff --git a/R/REGE.R b/R/REGE.R
new file mode 100644
index 0000000..ca26a7a
--- /dev/null
+++ b/R/REGE.R
@@ -0,0 +1,48 @@
+"REGE" <-
+function(M,E=1,iter=3,until.change=TRUE,use.diag=TRUE){
+ n<-dim(M)[1]
+ if(n!=dim(M)[2]) stop("M must be a 1-mode matrix")
+ if(!use.diag)diag(M)<-0
+ Eall<-array(NA,dim=c(n,n,iter+1)) #An array of 'iter' similiaritie matrices
+ Eall[,,1]<-E
+ Match<-array(NA,dim=rep(n,4))
+ for(i in 2:n){
+ for(j in 1:(i-1)){
+ for(k in 1:n){
+ for(m in 1:n){
+ Match[i,j,k,m]<-min(M[i,k],M[j,m]) + min(M[k,i],M[m,j])
+ Match[j,i,k,m] <- min(M[j,k],M[i,m]) + min(M[k,j],M[m,i])#/max(1,(max(M[i,k],M[j,m]) + max(M[k,i],M[m,j])+max(M[j,k],M[i,m]) + max(M[k,j],M[m,i])))
+ }
+ }
+ }
+ }
+
+ for(it in 1:iter){
+ for(i in 2:n){
+ for(j in 1:(i-1)){
+ num<-0
+ for(k in 1:n){
+ #sim<-max(Eall[k,,it]*Match[i,j,k,])
+ num<-num+max(Eall[k,,it]*Match[i,j,k,])+max(Eall[k,,it]*Match[j,i,k,])
+ #if(i==2&j==1)cat("num = ", num,", den = ",den,", k = ",k,", Maxm1 = ",Maxm1,", ms1 = ",ms1,", Maxm2 = ",Maxm2,", ms2 = ",ms2,"\n")
+ }
+ #cat("iter=",it,", i=",i,", j=",j,", num=",num,", den=", den,"\n")
+ den<-sum(M[c(i,j),])+sum(M[,c(i,j)])
+ if(den!=0) {
+ Eall[j,i,it+1]<-Eall[i,j,it+1]<-num/den
+ } else Eall[j,i,it+1]<-Eall[i,j,it+1]<-1
+ }
+ }
+ diag(Eall[,,it+1])<-1
+ if(until.change & all(Eall[,,it]==Eall[,,it+1])){
+ Eall<-Eall[,,1:(it+1)]
+ break
+ }
+ }
+ itnames<-0:(it)
+ itnames[1]<-"initial"
+ itnames[it+1]<-"final"
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],itnames)
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter,use.diag=use.diag))
+}
+
diff --git a/R/REGE.ow.R b/R/REGE.ow.R
new file mode 100644
index 0000000..29448a4
--- /dev/null
+++ b/R/REGE.ow.R
@@ -0,0 +1,54 @@
+"REGE.ow" <-
+function(M,E=1,iter=3,until.change=TRUE,use.diag=TRUE){
+ n<-dim(M)[1]
+ if(n!=dim(M)[2]) stop("M must be a 1-mode matrix")
+ if(length(dim(M))==2)M<-array(M,dim=c(n,n,1))
+ nr<-dim(M)[3]
+ if(!use.diag){for(ir in 1:nr) diag(M[,,ir])<-0}
+
+ Eall<-array(NA,dim=c(n,n,iter+1)) #An array of 'iter' similiaritie matrices
+ Eall[,,1]<-E
+ for(it in 1:iter){
+ for(i in 2:n){
+ for(j in 1:(i-1)){
+ num<-0
+ for(ir in 1:nr){
+ for(k in 1:n){
+ if(M[i,k,ir]>0) {
+ num<-num+max(Eall[k,,it]*pmin(M[i,k,ir],M[j,,ir]))
+ }
+
+ if(M[k,i,ir]>0) {
+ num<-num+max(Eall[k,,it]*pmin(M[k,i,ir],M[,j,ir]))
+ }
+
+ if(M[j,k,ir]>0) {
+ num<-num+max(Eall[k,,it]*pmin(M[j,k,ir],M[i,,ir]))
+ }
+
+ if(M[k,j,ir]>0) {
+ num<-num+max(Eall[k,,it]*pmin(M[k,j,ir],M[,i,ir]))
+ }
+
+ }
+ }
+ den<-sum(M[c(i,j),,])+sum(M[,c(i,j),])
+ if(den!=0) {
+ Eall[j,i,it+1]<-Eall[i,j,it+1]<-num/den
+ } else Eall[j,i,it+1]<-Eall[i,j,it+1]<-1
+ diag(Eall[,,it+1])<-1
+ }
+ }
+
+ if(until.change & all(Eall[,,it]==Eall[,,it+1])){
+ Eall<-Eall[,,1:(it+1)]
+ break
+ }
+ }
+ itnames<-0:(it)
+ itnames[1]<-"initial"
+ itnames[it+1]<-"final"
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],itnames)
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter,use.diag=use.diag))
+}
+
diff --git a/R/REGE_for.R b/R/REGE_for.R
new file mode 100644
index 0000000..108ed46
--- /dev/null
+++ b/R/REGE_for.R
@@ -0,0 +1,523 @@
+REGE.for<-function(
+ M, #netowrk in form of a matrix or array (in case of several relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("rege",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+REGD.for<-function(
+ M, #netowrk in form of a matrix or array (in case of several relations)
+ iter = 3,
+ E = 0 #initial dissimiliarity between vertices (default 0 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+ E<-matrix(as.double(E),ncol=N, nrow=N)
+
+ res<-.Fortran("regd",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+
+REGE.ow.for<-function(
+ M, #netowrk in form of a matrix or array (in case of several relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("regeow",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+REGD.ow.for<-function(
+ M, #netowrk in form of a matrix or array (in case of several relations)
+ iter = 3,
+ E = 0 #initial dissimiliarity between vertices (default 0 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+ E<-matrix(as.double(E),ncol=N, nrow=N)
+
+ res<-.Fortran("regdow",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dnM[[1]],dnM[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+
+
+
+REGE.ownm.for<-function(
+ M, #netowrk in form of a matrix or array (in case of two relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+
+ if(NR==1){
+ M2<-array(NA,dim=c(N,N,2))
+ M2[,,1]<-diag(1/apply(M,1,sum))%*%M
+ M2[,,2]<-M%*%diag(1/apply(M,2,sum))
+ M2[is.nan(M2)]<-0
+ NR<-2
+ if(length(dimnames(M))==2) dimN<-dimnames(M) else dimN<-c(list(NULL),list(NULL))
+ dimnames(M2)<-c(dimN,list(c("out","in")))
+ M<-M2
+ } else{
+ if(NR==2){
+ cat("The first matrix will be used to evalueate outgoing arcs and the second to evaluate in ingoing arcs.\n")
+ } else stop("This function is only suitable for evaluating two relations obtained as a row and column normalization of a single relation network. You have supplied more than two relations.\n")
+ }
+
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("regeownm",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+
+REGE.ownm.diag.for<-function(
+ M, #netowrk in form of a matrix or array (in case of two relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+
+ if(NR==1){
+ M2<-array(NA,dim=c(N,N,2))
+ M2[,,1]<-diag(1/apply(M,1,sum))%*%M
+ M2[,,2]<-M%*%diag(1/apply(M,2,sum))
+ M2[is.nan(M2)]<-0
+ NR<-2
+ if(length(dimnames(M))==2) dimN<-dimnames(M) else dimN<-c(list(NULL),list(NULL))
+ dimnames(M2)<-c(dimN,list(c("out","in")))
+ M<-M2
+ } else{
+ if(NR==2){
+ cat("The first matrix will be used to evalueate outgoing arcs and the second to evaluate in ingoing arcs.\n")
+ } else stop("This function is only suitable for evaluating two relations obtained as a row and column normalization of a single relation network. You have supplied more than two relations.\n")
+ }
+
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("regeownmdiag",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+
+
+
+REGE.nm.for<-function(
+ M, #netowrk in form of a matrix or array (in case of two relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+
+ if(NR==1){
+ M2<-array(NA,dim=c(N,N,2))
+ M2[,,1]<-diag(1/apply(M,1,sum))%*%M
+ M2[,,2]<-M%*%diag(1/apply(M,2,sum))
+ M2[is.nan(M2)]<-0
+ NR<-2
+ if(length(dimnames(M))==2) dimN<-dimnames(M) else dimN<-c(list(NULL),list(NULL))
+ dimnames(M2)<-c(dimN,list(c("out","in")))
+ M<-M2
+ } else{
+ if(NR==2){
+ cat("The first matrix will be used to evalueate outgoing arcs and the second to evaluate in ingoing arcs.\n")
+ } else stop("This function is only suitable for evaluating two relations obtained as a row and column normalization of a single relation network. You have supplied more than two relations.\n")
+ }
+
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("regenm",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+REGE.nm.diag.for<-function(
+ M, #netowrk in form of a matrix or array (in case of two relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+
+ if(NR==1){
+ M2<-array(NA,dim=c(N,N,2))
+ M2[,,1]<-diag(1/apply(M,1,sum))%*%M
+ M2[,,2]<-M%*%diag(1/apply(M,2,sum))
+ M2[is.nan(M2)]<-0
+ NR<-2
+ if(length(dimnames(M))==2) dimN<-dimnames(M) else dimN<-c(list(NULL),list(NULL))
+ dimnames(M2)<-c(dimN,list(c("out","in")))
+ M<-M2
+ } else{
+ if(NR==2){
+ cat("The first matrix will be used to evalueate outgoing arcs and the second to evaluate in ingoing arcs.\n")
+ } else stop("This function is only suitable for evaluating two relations obtained as a row and column normalization of a single relation network. You have supplied more than two relations.\n")
+ }
+
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("regenmdiag",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+
+
+
+
+REGE.ne.for<-function(
+ M, #netowrk in form of a matrix or array (in case of several relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("regene",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+REGE.ow.ne.for<-function(
+ M, #netowrk in form of a matrix or array (in case of several relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("regeowne",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+REGE.ownm.ne.for<-function(
+ M, #netowrk in form of a matrix or array (in case of two relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+
+ if(NR==1){
+ M2<-array(NA,dim=c(N,N,2))
+ M2[,,1]<-diag(1/apply(M,1,sum))%*%M
+ M2[,,2]<-M%*%diag(1/apply(M,2,sum))
+ M2[is.nan(M2)]<-0
+ NR<-2
+ if(length(dimnames(M))==2) dimN<-dimnames(M) else dimN<-c(list(NULL),list(NULL))
+ dimnames(M2)<-c(dimN,list(c("out","in")))
+ M<-M2
+ } else{
+ if(NR==2){
+ cat("The first matrix will be used to evalueate outgoing arcs and the second to evaluate in ingoing arcs.\n")
+ } else stop("This function is only suitable for evaluating two relations obtained as a row and column normalization of a single relation network. You have supplied more than two relations.\n")
+ }
+
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("regeownmne",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+
+
+
+REGE.nm.ne.for<-function(
+ M, #netowrk in form of a matrix or array (in case of two relations)
+ iter = 3,
+ E = 1 #initial similiarity between vertices (default 1 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+
+ if(NR==1){
+ M2<-array(NA,dim=c(N,N,2))
+ M2[,,1]<-diag(1/apply(M,1,sum))%*%M
+ M2[,,2]<-M%*%diag(1/apply(M,2,sum))
+ M2[is.nan(M2)]<-0
+ NR<-2
+ if(length(dimnames(M))==2) dimN<-dimnames(M) else dimN<-c(list(NULL),list(NULL))
+ dimnames(M2)<-c(dimN,list(c("out","in")))
+ M<-M2
+ } else{
+ if(NR==2){
+ cat("The first matrix will be used to evalueate outgoing arcs and the second to evaluate in ingoing arcs.\n")
+ } else stop("This function is only suitable for evaluating two relations obtained as a row and column normalization of a single relation network. You have supplied more than two relations.\n")
+ }
+
+ E<-matrix(E,ncol=N, nrow=N)
+ res<-.Fortran("regenmne",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+REGD.ne.for<-function(
+ M, #netowrk in form of a matrix or array (in case of several relations)
+ iter = 3,
+ E = 0 #initial dissimiliarity between vertices (default 0 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+ E<-matrix(as.double(E),ncol=N, nrow=N)
+
+ res<-.Fortran("regdne",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
+
+REGD.ow.ne.for<-function(
+ M, #netowrk in form of a matrix or array (in case of several relations)
+ iter = 3,
+ E = 0 #initial dissimiliarity between vertices (default 0 among all vertices).
+){
+ if(is.array(M)){
+ dM<-dim(M)
+ dnM<-dimnames(M)
+ N<-dM[1]
+ if (length(dM)==3) {
+ NR<-dM[3]
+ } else {
+ if(length(dM)==2) {
+ NR<-1
+ } else stop("An array has wrong dimensions")
+ }
+ } else stop("M must be an array")
+ M<-structure(as.double(M),dim=dM)
+ dimnames(M)<-dnM
+ E<-matrix(as.double(E),ncol=N, nrow=N)
+
+ res<-.Fortran("regdowne",M = M, E = E, N = as.integer(N), NR = as.integer(NR), iter = as.integer(iter))
+ Eall<-array(NA,dim=c(dim(E),2))
+ Eall[,,1]<-E
+ Eall[,,2]<-res$E
+ dimnames(Eall)<-list(dnM[[1]],dnM[[2]],c("initial","final"))
+ return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter))
+}
+
+
diff --git a/R/ad.R b/R/ad.R
new file mode 100644
index 0000000..8290466
--- /dev/null
+++ b/R/ad.R
@@ -0,0 +1,3 @@
+"ad" <-
+function(x)sum(abs(x-median(x)))
+
diff --git a/R/check.these.par.R b/R/check.these.par.R
new file mode 100644
index 0000000..bebd7d6
--- /dev/null
+++ b/R/check.these.par.R
@@ -0,0 +1,48 @@
+"check.these.par" <-
+function( #saves the resoult of call a to crit.fun of the best partition and only errors for the rest
+ M, #matrix (network)
+ partitions, #partitions to check
+ approach, #
+ return.err=TRUE, #if 'FALSE', only the resoults of crit.fun are returned (a list of all (best) soulutions including errors), else the resoult is list
+ save.initial.param=TRUE, #should the initial parameters be saved
+# use.for=TRUE, #should fortran rutines be used when possible
+ force.fun=NULL, #select the function used to evaluate partition
+ ... #paremeters for "gen.crit.fun"
+){
+ if(save.initial.param){
+ initial.param<-list(initial.param=tryCatch(lapply(as.list(sys.frame(sys.nframe())),eval),error=function(...)return("error"))) #saves the inital parameters
+ }else initial.param<-NULL
+
+ err<-NULL
+
+ if(is.list(partitions[[1]])){
+ k<-sapply(partitions[[1]],function(x)length(unique(x)))
+ } else k<-length(unique(partitions[[1]]))
+ eval(gen.crit.fun(M=M,k=k,approach=approach,changeT=FALSE,...))
+
+
+ res<-crit.fun.tmp(M=useM,clu=partitions[[1]])
+ best<-list(res)
+ err[1]<-res$err
+ min.err<-res$err
+
+ for(i in 2:length(partitions)){
+ res<-crit.fun.tmp(M=useM,clu=partitions[[i]])
+ if(res$err<=min.err){
+ if(res$err<min.err) {
+ best<-list(res)
+ min.err<-res$err
+ }else best<-c(best,list(res))
+ }
+ err[i]<-res$err
+ }
+
+ names(best)<-paste("best",1:length(best),sep="")
+ call<-list(call=match.call())
+ best<-list(best=best)
+ if(return.err) err<-list(err=err) else err<-NULL
+ res<-c(list(M=M),best,err,call,initial.param)
+ class(res)<-"check.these.par"
+ return(res)
+}
+
diff --git a/R/clu.R b/R/clu.R
new file mode 100644
index 0000000..ea518ca
--- /dev/null
+++ b/R/clu.R
@@ -0,0 +1,7 @@
+"clu" <-
+function(res,which=1,...){
+ res$best[[which]]$clu
+}
+
+"partitions" <-
+function(res)lapply(res$best,function(x)x$clu)
diff --git a/R/crand.R b/R/crand.R
new file mode 100644
index 0000000..fa797f7
--- /dev/null
+++ b/R/crand.R
@@ -0,0 +1,10 @@
+"crand" <-
+function (tab) #Hubert & Arabie
+{
+ n <- sum(tab)
+ sum.ni2 <- sum(choose(rowSums(tab), 2))
+ sum.nj2 <- sum(choose(colSums(tab), 2))
+ E<- sum.ni2 * sum.nj2 / choose(n, 2)
+ return((sum(choose(tab, 2)) - E)/((sum.ni2 + sum.nj2)/2 - E))
+}
+
diff --git a/R/crand2.R b/R/crand2.R
new file mode 100644
index 0000000..f30f8c1
--- /dev/null
+++ b/R/crand2.R
@@ -0,0 +1,11 @@
+"crand2" <-
+function (clu1,clu2) #Hubert & Arabie
+{
+ tab<-table(clu1,clu2)
+ n <- sum(tab)
+ sum.ni2 <- sum(choose(rowSums(tab), 2))
+ sum.nj2 <- sum(choose(colSums(tab), 2))
+ E<- sum.ni2 * sum.nj2 / choose(n, 2)
+ return((sum(choose(tab, 2)) - E)/((sum.ni2 + sum.nj2)/2 - E))
+}
+
diff --git a/R/crit.fun.R b/R/crit.fun.R
new file mode 100644
index 0000000..69c1c7e
--- /dev/null
+++ b/R/crit.fun.R
@@ -0,0 +1,47 @@
+"crit.fun" <-
+function(
+ #function for generting a function for computing criteria function of a blockmodel and preparing data
+ M, #matrix,
+ clu, #partition
+# e1="default", #weight of the error of binearized matrix
+# e2="default", #weight of the error of valued conenctions
+ approach, #the approach used - can be one of "ss","ad","bin","val", "bv", "imp", "bi"
+# cut = min(M[M>0]),
+# m=ifelse(e2==0,1,"default"), #suficient value for individual cells
+# s="default", #suficient value for colum and row statistics
+# FUN="max", #function to calculate row and colum statistics
+# norm=FALSE,
+# blocks=c("null","com","reg"), #permissible block types and their ordering, can be also on of 'structural', 'regular', 'regular.ext' or 'all'
+# BLOCKS=NULL, #prespecified model
+# mindim = 2, #minimal dimension for regulal, dominant and functional blocks
+# block.weights=c(null=1,com=1,rdo=1,cdo=1,reg=1,rre=1,cre=1), #weights for all block types - if only some of them are specified, the other remain 0
+# fixed.clu=NULL, #used to specify groups that are not to be evaluated - the blocks that are dependent only on these groups will not be evaluetad
+# initial.IM=NULL, #an image matrix, usualy the resoult of previou crit.fun call, component "IM" - used only if part of the matrix is fixed - for the solution of the fixed part
+# initial.E=NULL, #an error matrix, usualy the resoult of previou crit.fun call, component "E" - used only if part of the matrix is fixed - for the solution of the fixed part
+# save.err.v=FALSE, #save a vector of errors of all block tipes for all blocks
+# max.con.val="non", #should the largest values be cencored, limited to (larger values set to) - resonoble values are:
+# # "m" or "s" - the maximum value equals the value of the parameter m/s
+# # "non" - no transformation is done
+# # other values larger then parameters m and s and lower the the maximum
+# dn=mean(M>=cut),
+ ...
+){
+ if(is.list(clu)){
+ k<-sapply(clu,function(x)length(unique(x)))
+ clu<-lapply(clu,function(x)as.integer(factor(x)))
+ if(length(k)>2) {
+ for(i in 2:length(clu)){
+ clu[[i]]<-clu[[i]] + max(clu[[i-1]])
+ }
+ }
+ } else {
+ k<-length(unique(clu))
+ clu<-as.integer(factor(clu))
+ }
+
+ eval(gen.crit.fun(M=M,k=k,approach=approach,changeT=FALSE,...))
+ res<-c(list(M=M),crit.fun.tmp(M=useM,clu=clu),call=match.call())
+ class(res)<-"crit.fun"
+ return(res)
+}
+
diff --git a/R/err.R b/R/err.R
new file mode 100644
index 0000000..2988d44
--- /dev/null
+++ b/R/err.R
@@ -0,0 +1,5 @@
+"err" <-
+function(res,...){
+ res$best[[1]]$err
+}
+
diff --git a/R/find.cut.R b/R/find.cut.R
new file mode 100644
index 0000000..aba55b8
--- /dev/null
+++ b/R/find.cut.R
@@ -0,0 +1,41 @@
+"find.cut" <-
+function(
+ M, #matrix of a network
+ clu, #partition
+ alt.blocks="reg", #alternative block to null block
+ cuts="all", #maximumvnumber of evaluations at different cuts
+ ... #other parameters to crit.fun
+){
+ if(cuts=="all"){
+ allvals<-sort(unique(M))
+ # allvals<-allvals[allvals>0]
+ if(length(allvals)>1000) cat(length(allvals), "evaluations will be made.\n")
+ cuts<-allvals
+ }
+
+ if(is.list(clu)){
+ k<-sapply(clu,function(x)length(unique(x)))
+ clu<-lapply(clu,function(x)as.integer(factor(x)))
+ if(length(k)>2) {
+ for(i in 2:length(clu)){
+ clu[[i]]<-clu[[i]] + max(clu[[i-1]])
+ }
+ k2<-max(clu[[length(clu)]])
+ } else k2<-k
+ } else {
+ k<-length(unique(clu))
+ clu<-as.integer(factor(clu))
+ k2<-c(k,k)
+ }
+ res.IM<-array(NA,dim=c(k2[1],k2[2],length(cuts)))
+ res.IM[,,1]<-alt.blocks
+ for(i in 1:length(cuts)) res.IM[,,i]<-crit.fun(M=M,clu=clu,blocks=c("null",alt.blocks),cut=cuts[i],approach="bin",...)$IM
+ cut<-matrix(NA,nrow=k2[1],ncol=k2[2])
+ for(i in 1:k2[1]){
+ for(j in 1:k2[2]){
+ cut[i,j]<- max(cuts[which(res.IM[i,j,]==alt.blocks)])
+ }
+ }
+ return(cut)
+}
+
diff --git a/R/find.m.R b/R/find.m.R
new file mode 100644
index 0000000..ce5fca6
--- /dev/null
+++ b/R/find.m.R
@@ -0,0 +1,81 @@
+"find.m" <-
+function(
+ M, #matrix of a network
+ clu, #partition
+ alt.blocks="reg", #alternative block to null block (for now only "reg" is supported)
+ diag=!is.list(clu) ,#allow diagonal blocks
+ cormet="none", #should we correct for diferent maxismum error contributins
+ # "censor" - censor values larger than m
+ # "correct" - so that the maxsimum possible error contribution of the cell is the same regardles of a condition (either that somthing must be o or at least m)
+ half = TRUE, # should the returned value of m be one half of the value where the incosnistencies are the same, otherwise, the m is restricted to max(M)
+ FUN="max"
+){
+ mx<-max(M)*(1+ half)
+ mn<-min(M)
+ diag=diag
+ if(is.list(clu)){
+ k<-sapply(clu,function(x)length(unique(x)))
+ clu<-lapply(clu,function(x)as.integer(factor(x)))
+ if(length(k)>2) {
+ for(i in 2:length(clu)){
+ clu[[i]]<-clu[[i]] + max(clu[[i-1]])
+ }
+ clu<-unlist(clu)
+ clu<-list(clu,clu)
+ }
+ } else {
+ clu<-as.integer(factor(clu))
+ clu<-list(clu,clu)
+ k<-sapply(clu,function(x)length(unique(x)))
+ }
+
+ m<-matrix(NA,nrow=k[1],ncol=k[2])
+ err<-list(
+ reg=function(B,m,FUN){
+ nr<-dim(B)[1] #numer of rows
+ nc<-dim(B)[2] #numer of colums
+ sr<-apply(B,1,FUN);er<-m-sr[sr<m]
+ sc<-apply(B,2,FUN);ec<-m-sc[sc<m]
+ return(sum(er)*nc+ sum(ec)*nr - sum(pmin(rep(er,times=length(ec)),rep(ec,each=length(er))))) #regular block error
+ },
+ com=function(B,m,FUN){sumpos(m-B)}
+ )
+
+ errd<-list(
+ com=function(B,m,FUN){sumpos(m-B) + min(0,sum(diag(B))-sumpos(m-diag(B)))},
+ reg=function(B,m,FUN){
+ nr<-dim(B)[1] #numer of rows
+ nc<-dim(B)[2] #numer of colums
+ sr<-apply(B,1,FUN);er<-m-sr[sr<m]
+ sc<-apply(B,2,FUN);ec<-m-sc[sc<m]
+ return(sum(er)*nc+ sum(ec)*nr - sum(pmin(rep(er,times=length(ec)),rep(ec,each=length(er))))) #regular block error
+ }
+ )
+ errd.null<-function(B,m){sum(B) - min(0,sum(diag(B))-sumpos(m-diag(B)))}
+
+ for(i in 1:k[1]){
+ for(j in 1:k[2]){
+ B<-M[clu[[1]]==i,clu[[2]]==j, drop=FALSE]
+ if(ss(B)==0) m[i,j]<-min(2*B[1,1],mx) else if(i==j&&diag&&sum(dim(B))>1){
+ if(errd.null(B,m=mx)>=errd[[alt.blocks]](B,mx,FUN)*ifelse(cormet=="correct",(mx - 0)/(mx - mn),1)){
+ m[i,j]<-mx
+ }else{
+ m[i,j]<-optimize(f=function(m,B,alt.blocks,FUN,cormet,mx,mn){corf<-ifelse(cormet=="correct", (mx - 0)/(m - mn),1); if(cormet=="censor") B[B>m]<-m;(errd.null(B,m)-errd[[alt.blocks]](B,m,FUN)*corf)^2},lower=ifelse(cormet=="censor",mn,0),upper=mx,B=B,FUN=FUN,alt.blocks=alt.blocks,cormet=cormet,mx=mx,mn=mn)$minimum
+ if(cormet=="correct" && errd.null(B)<err[[alt.blocks]](B,m[i,j],FUN)*(mx - 0)/(m[i,j] - mn)) m[m<=min(B)]<-0
+ }
+
+ }else{
+ if(sum(B)>=err[[alt.blocks]](B,mx,FUN)*ifelse(cormet=="correct",(mx - 0)/(mx - mn),1)){
+ m[i,j]<-mx
+ }else{
+ m[i,j]<-optimize(f=function(m,B,alt.blocks,FUN,cormet,mx,mn){corf<-ifelse(cormet=="correct", (mx - 0)/(m - mn),1); if(cormet=="censor") B[B>m]<-m;(sum(B)-err[[alt.blocks]](B,m,FUN)*corf)^2},lower=ifelse(cormet=="censor",mn,0),upper=mx,B=B,FUN=FUN,alt.blocks=alt.blocks,cormet=cormet,mx=mx,mn=mn)$minimum
+ if(cormet=="correct" && sum(B)<err[[alt.blocks]](B,m[i,j],FUN)*(mx - 0)/(m[i,j] - mn)) m[m<=min(B)]<-0
+ }
+ }
+ }
+ }
+ if(cormet=="censor") m[m<min(M[M>0])]<-0
+ if(half) m<-m/2
+ return(m)
+}
+
diff --git a/R/find.m2.R b/R/find.m2.R
new file mode 100644
index 0000000..7c33253
--- /dev/null
+++ b/R/find.m2.R
@@ -0,0 +1,42 @@
+"find.m2" <-
+function(
+ M, #matrix of a network
+ clu, #partition
+ alt.blocks="reg", #alternative block to null block
+ neval=100, #number of evaluations at different ms
+ half = TRUE, # should the returned value of m be one half of the value where the incosnistencies are the same, otherwise, the m is restricted to max(M)
+ ms=NULL, #the values of m where the function should be evaluated
+ ... #other parameters to crit.fun
+){
+ if(is.null(ms)){
+ ms<-seq(from=min(M), to=max(M)*(1+half), length.out=neval)
+ } else neval<-length(ms)
+
+ if(is.list(clu)){
+ k<-sapply(clu,function(x)length(unique(x)))
+ clu<-lapply(clu,function(x)as.integer(factor(x)))
+ if(length(k)>2) {
+ for(i in 2:length(clu)){
+ clu[[i]]<-clu[[i]] + max(clu[[i-1]])
+ }
+ k2<-max(clu[[length(clu)]])
+ } else k2<-k
+ } else {
+ k<-length(unique(clu))
+ clu<-as.integer(factor(clu))
+ k2<-c(k,k)
+ }
+ res.IM<-array(NA,dim=c(k2[1],k2[2],length(ms)))
+ for(i in 1:neval) res.IM[,,i]<-crit.fun(M=M,clu=clu,blocks=c("null",alt.blocks),m=ms[i],approach="val",...)$IM
+ m<-matrix(NA,nrow=k2[1],ncol=k2[2])
+ for(i in 1:k2[1]){
+ for(j in 1:k2[2]){
+ m[i,j]<- max(ms[which(res.IM[i,j,]==alt.blocks)])
+ }
+ }
+ m[m== -Inf]<-0
+ if(half) m<-m/2
+ return(m)
+}
+
+
diff --git a/R/formatA.R b/R/formatA.R
new file mode 100644
index 0000000..4696072
--- /dev/null
+++ b/R/formatA.R
@@ -0,0 +1,5 @@
+"formatA" <-
+function(x,digits=2, FUN=round,...){
+ noquote(format(FUN(x, digits=digits),...))
+}
+
diff --git a/R/fun.by.blocks.R b/R/fun.by.blocks.R
new file mode 100644
index 0000000..9661d46
--- /dev/null
+++ b/R/fun.by.blocks.R
@@ -0,0 +1,3 @@
+"fun.by.blocks" <-
+function(x, ...) UseMethod("fun.by.blocks")
+
diff --git a/R/fun.by.blocks.default.R b/R/fun.by.blocks.default.R
new file mode 100644
index 0000000..694c7b6
--- /dev/null
+++ b/R/fun.by.blocks.default.R
@@ -0,0 +1,32 @@
+"fun.by.blocks.default" <-
+function(x=M, M=x, clu, ignore.diag = identical(ss(diag(M)), 0)&&!is.list(clu), FUN = "mean",sortNames=TRUE,...)
+{
+ if(is.list(clu)){
+ nmode<-length(clu)
+ if(nmode>2){
+ clu<-unlist(clu)
+ clu<-list(clu,clu)
+ }
+ } else {
+ clu<-list(clu,clu)
+ nmode<-1
+ }
+
+ if(sortNames) {
+ k <- lapply(clu,function(x)sort(as.character(unique(x))))
+ }else {
+ k <- lapply(clu,function(x)as.character(unique(x)))
+ }
+ IM.V <- matrix(NA, nrow = length(k[[1]]), ncol = length(k[[2]]))
+ dimnames(IM.V)<-k
+ for (i in k[[1]]) {
+ for (j in k[[2]]) {
+ B <- M[clu[[1]] == i, clu[[2]] == j, drop = FALSE]
+ if (nmode==1 && i == j && dim(B)[1] > 1 && ignore.diag)
+ diag(B) <- NA
+ IM.V[i, j] <- do.call(FUN, list(x = B, na.rm = TRUE))
+ }
+ }
+ return(IM.V)
+}
+
diff --git a/R/fun.by.blocks.opt.more.par.R b/R/fun.by.blocks.opt.more.par.R
new file mode 100644
index 0000000..f335567
--- /dev/null
+++ b/R/fun.by.blocks.opt.more.par.R
@@ -0,0 +1,13 @@
+"fun.by.blocks.opt.more.par" <-
+function(
+ x, #an object of class "opt.more.par"
+ which=1, #which best solution/partition should be used
+ ... #aditional parameters to function "fun.by.blocks"
+){
+ if(which>length(x$best)){
+ which<-1
+ warning("Only",length(x$best),"solutions exists. The first solution will be used.")
+ }
+ fun.by.blocks(M=x$M, clu=clu(x,which=which),...)
+}
+
diff --git a/R/gen.crit.fun.R b/R/gen.crit.fun.R
new file mode 100644
index 0000000..73f0b78
--- /dev/null
+++ b/R/gen.crit.fun.R
@@ -0,0 +1,692 @@
+"gen.crit.fun" <-
+function(
+ #function for generting a function for computing criteria function of a blockmodel and preparing data
+ M, #matrix or an array in case of multirelational networks with dimensions N x N x R, where N is the number of vertices and R the number of relations,
+ k, #number partitions for each mode
+# e1="default", #weight of the error of binearized matrix
+# e2="default", #weight of the error of valued conenctions
+ approach, #the approach used - can be one of "ss","ad","bin","val", "imp" (yet to be implementer) , "bv", "bi". A vector if different approaches should be used for different relations.
+ cut = if(length(dim(M))==2) min(M[M>0]) else apply(M,3,function(x)min(x[x>0])), #the cutting parameter used to binerize a valued network m=NULL, #suficient value for individual cells, can be specified as a number or a function of a block (or only one of its rows or coulms anslyzed) (max for implicit appraoch)
+ m= NULL,
+# s="default", #suficient value for colum and row statistics
+ FUN="max", #function to calculate row and colum statistics
+ blocks=NULL, #permissible block types and their ordering, can be also on of 'structural', 'regular', 'regular.ext' or 'all'. A list if different permissible block types and their ordering should be applied to different relations.
+ BLOCKS=NULL, #prespecified model, a list if different blockmodels should be applied to different relations
+ diag = TRUE, #should the diagonal blocks be treated as diagonal blocks
+ relWeights = NULL, #the weights for different relations in the array M - can be also used for combining criterion functions of several approaches to blockmodeling
+ normMto2rel=FALSE, #create two-realation netowrk from one relational network through row and column normalization.
+ normMto2relRegToRreCre = normMto2rel, #when normMto2rel is TRUE, should regular blocks be converted to row-regular in row-normalized relation and to column-regular in column-normalized relation.
+ sameModel=normMto2rel, #should we damand the same blockmodel for all relations. If set to TRUE, it demands that accros all relations the ideal block on the same position in the matrix BLOCKS should be chosen. Usually, these positions are occupied by the same blocks. If not, use with caution.
+ mindim = 2, #minimal dimension for rew/column regular, dominant and functional blocks
+ mindimreg = FALSE, #should mindim be also used for regular blocks
+ regDiagSep = FALSE, #should the diagonal be treated sepeartly in regular blocks -> not used in evalution of funtion f by rows or columns but as the diagonal in null and complete blocks? Currently only supported for homogeneity blockmodeling
+ blockWeights=NULL, #weights for all block types - if only some of them are specified, the other remain 1
+ positionWeights=NULL, #weigths for positions in the blockmodel (the dimensions must be the same as the error matrix)
+ save.err.v=sameModel, #save a vector of errors of all block tipes for all blocks
+ changeT=FALSE, #do we also want a function for computing only the chages in the blockmodel/errors
+ dn="default", #the density reshold for density block - default = mean(M>=cut)
+ av="default", #the treshold for average block - default = mean(M)
+ norm= FALSE, #should the block errors be normalised by the size of the blocks
+ normbym = FALSE,#should the block errors be normalised by m
+ allow.max0 = !"null" %in% unique(c(unlist(blocks),unlist(BLOCKS))), #Should the maximum that is the basis for calculation of inconsistencies in implicit blockmodeling be allowed to be 0. If FALSE, the maximum is in such case set to the maximum of the network (if maximum of a block is 0) or to the maxsimum of the block (if row or column maxismum is 0)
+ #Used only in implicit blockmodeling
+ allow.dom0=FALSE, #should the dominant row or column be allowed to be 0. Used only in implicit blockmodeling.
+ domMax=TRUE, #should it be allowed that the dominant row or column is not the one with the largest sum, max,... Not yet used.
+ max.con.val=if(normbym && approach!="imp") "m" else "non" , #used only in valued and implicit blockmodeling - should the largest values be cencored, limited to (larger values set to) - resonoble values are:
+ # "m" or "s" - the maximum value equals the value of the parameter m/s
+ # "non" - no transformation is done
+ # numeriacal values larger then parameters m and s and lower the the maximum
+ BLOCKS.CV=NULL, #prespecified block central values for homogeneity blockmodeling - must have the same dimensions as BLOCKS
+ CV.use=NULL, #how should the prespecified block central values for homogeneity blockmodeling be used - possible values are "fixed","min" and "max".
+ return.CV=TRUE, #should a matrix of block central values (for homogeneity blockmodeling only) be returned.
+ use.for=TRUE, #should fotran subrutines be used when possible
+ ...
+){
+# cat("Start: approach = ",approach,", normbym = ", normbym,", norm = ", norm, "\n", sep="")
+
+# norm
+# normbym
+# max.con.val
+
+ if(!is.null(positionWeights))assign(x="pWeights",value=positionWeights,envir=parent.frame())
+
+ if(is.null(blocks)&&is.null(BLOCKS))stop("Either blocks or BLOCKS must be specified!\n")
+ bin.all.ideal.blocks<-c("null","com","rdo","cdo","reg","rre","cre","rfn","cfn","den","dnc")
+ val.all.ideal.blocks<-c("null","com","rdo","cdo","reg","rre","cre","rfn","cfn","avg","dnc")
+ hom.all.ideal.blocks<-c("null","com","rdo3","cdo3","rdo1","cdo1","rdo2","cdo2","rfn","cfn","reg","rre","cre","dnc") #blocks "rdo1","cdo1","rdo2","cdo2","rfn","cfn" are in testing phase and are also not implemented for pre-specified blocks central values.
+ tmpfun<-"crit.fun.tmp"
+ M<-as.array(M)
+ if(length(dim(M))==3){
+ nr<-dim(M)[3]
+ } else nr<-1
+
+ if(sameModel){
+ if(!is.null(BLOCKS)){
+ if(is.list(blocks)){
+ for(i in 2:length(blocks)){
+ if(!all(blocks[[1]]==blocks[[i]])){
+ warning("sameModel used with diferent allowed blocks for different relations\n")
+ break
+ }
+ }
+ }
+ }else{
+ if(is.list(BLOCKS)){
+ for(i in 2:length(BLOCKS)){
+ if(!all(BLOCKS[[1]]==BLOCKS[[i]])){
+ warning("sameModel used with diferent BLOCKS for different relations\n")
+ break
+ }
+ }
+ }
+ }
+ }
+
+ nmode<-length(k)
+
+
+ if(nmode==1){
+ k<-c(k,k)
+ } else diag<-FALSE
+
+ if(normMto2rel){
+ if(is.matrix(M)){
+ LM<-array(NA,dim=c(dim(M),2))
+ LM[,,1]<-diag(1/rowSums(M))%*%M
+ LM[,,2]<- M%*%diag(1/colSums(M))
+ LM[is.nan(LM)]<-0
+ M<-LM
+ if(is.null(BLOCKS)){
+ BLOCKS.org<-array(blocks,dim=c(length(blocks),k[1],k[2])) #,dimnames=list(NULL,nclu,nclu)
+ } else if(!is.list(BLOCKS)) BLOCKS.org<-BLOCKS
+
+ if(!is.list(BLOCKS)){
+ BLOCKS2<-BLOCKS1<-BLOCKS.org
+ if(normMto2relRegToRreCre){
+ BLOCKS1[BLOCKS1=="reg"]<-"rre"
+ BLOCKS2[BLOCKS2=="reg"]<-"cre"
+ }
+ BLOCKS<-list(BLOCKS1,BLOCKS2)
+ } else if(length(BLOCKS)!=2) stop("BLOCKS must be a list of legnth 2 for the use with normMto2rel!\n")
+ nr<-2
+ }else stop("normMto2rel = TRUE can be only used on one relational networks.\n")
+ }
+ if(is.matrix(M)) class(M)<-"mat"
+
+ if(nr==1){
+ directed<-nmode==2||!all(M==t(M))
+ } else{
+ directed<-nmode==2||!all(apply(M,3,function(x)all(x==t(x))))
+ }
+
+ if(nr!=length(approach)){
+ if(nr==1) M<-array(M,dim=c(dim(M),length(approach)))
+ }
+
+
+ if(nmode>2){
+ kmode<-k
+ k<-c(sum(k),sum(k))
+ }
+
+
+ if(nr==1){
+ sameModel<-FALSE
+ if(is.null(BLOCKS)){
+ BLOCKS<-array(blocks,dim=c(length(blocks),k[1],k[2])) #,dimnames=list(NULL,nclu,nclu)
+ }else {
+ blocks<-unique(na.omit(as.vector(BLOCKS)))
+ }
+ n.types<-length(blocks)
+ }else{
+ if(is.null(relWeights))relWeights<-rep(1,nr)
+ if(length(relWeights)!=nr) stop("Length of relWeights does not match the number of relations (the third dimmension of M).")
+ if(is.null(BLOCKS)){
+ if(!is.list(blocks)){
+ blocks<-rep(list(blocks),times=nr)
+ }
+ BLOCKS<-lapply(blocks,function(x)array(x,dim=c(length(x),k[1],k[2])))
+ }else {
+ if(!is.list(BLOCKS)){
+ BLOCKS<-rep(list(BLOCKS),times=nr)
+ }
+ blocks<-lapply(BLOCKS,function(x)unique(as.vector(x)))
+ }
+ n.types<-sapply(blocks,length)
+ }
+
+ # dimnames(BLOCKS)<-list(NULL,nclu,nclu)
+ #}
+
+ assign(x="expBLOCKS",value=BLOCKS,envir=parent.frame())
+
+
+ if(sameModel&&nr>1&&(sum(apply(sapply(BLOCKS,dim),1,ss))!=0)){
+ stop("sameModel used with BLOCKS with diferent dimensions\n")
+ }
+
+
+ normal<-TRUE
+
+
+ if(nr==1 && all(approach=="ss") && all(blocks=="com")&& all(BLOCKS=="com") && nmode==1 && use.for){
+ assign(x="useM",value=M,envir=parent.frame())
+ fun1<-(parse(text=paste(c(tmpfun,"<-function(M,clu,...){
+ n<-dim(M)[1]
+ dn<-dimnames(M)
+ k<-as.integer(",k[1],")
+ clu<-as.integer(factor(clu))
+ res<- .Fortran('critfunsscom',M=matrix(as.double(M),ncol=n),n=n,clu=clu, k=k,diag=",diag,",err=0,E=diag(k), BM=diag(k))
+ class(res)<-'crit.fun'
+ dn->dimnames(res$M)
+ IM<-res$E
+ IM[,] <- 'com'
+ res$IM<-IM
+ return(res[c('err','clu','E','IM','BM')])}
+ "),sep="",collapse="")))
+
+ if(changeT){
+ return(list(fun1 = fun1, fun2 = fun1))
+ } else {
+ return(fun1)
+ }
+
+ normal<-FALSE
+ }
+
+ if(normal){
+ if(nr==1){
+ if(!is.null(blockWeights)){
+ use.weights<-TRUE
+ w<-rep(1, times=length(blocks))
+ names(w)<-blocks
+ w[names(blockWeights)]<-blockWeights
+ blockWeights<-w
+ assign(x="bweights",value=blockWeights,envir=parent.frame())
+ } else use.weights<-FALSE
+ }else{
+ if(!is.null(blockWeights)){
+ use.weights<-TRUE
+ ww<-NULL
+ for(i in 1:nr){
+ w<-rep(1, times=length(blocks[[i]]))
+ names(w)<-blocks[[i]]
+ if(is.list(blockWeights)){
+ w[names(blockWeights[[i]])]<-blockWeights[[i]]
+ }else{
+ w[names(blockWeights)]<-blockWeights
+ }
+ ww<-c(ww,list(w))
+ }
+ blockWeights<-ww
+ assign(x="bweights",value=blockWeights,envir=parent.frame())
+ } else use.weights<-FALSE
+ }
+
+
+
+
+ fun<-c(tmpfun,"<-function(M,clu,mindim=",mindim,if(use.weights)",blockWeights=bweights" else NULL, if(sameModel)",BLOCKS=expBLOCKS" else NULL,if(!is.null(positionWeights))",positionWeights=pWeights",if(any(approach%in%c("val","imp")))",m=exm","){\n")
+ if(changeT) {fun2<-c(tmpfun,"<-function(M,clu,mindim=",mindim,if(use.weights)",blockWeights=bweights" else NULL, if(sameModel)",BLOCKS=expBLOCKS" else NULL,if(!is.null(positionWeights))",positionWeights=pWeights",if(any(approach%in%c("val","imp")))",m=exm",",change",if(nmode==2)", modechange" else NULL,",res.old){\n")}
+ fun<-c(fun,"E<-array(NA,dim=c(",k[1],",",k[2],if(nr>1)c(",",nr)else NULL,"))\n","IM<-array(NA,dim=c(",k[1],",",k[2],if(nr>1)paste(",",nr,sep="")else NULL,"))\n")
+ if(changeT) {
+ fun2<-c(fun2,"E<-res.old$E\n",if(normMto2rel) "IM = res.old$completeIM\n" else "IM<-res.old$IM\n") #image matrix - matrix of types of blocks #,dimnames=list(nclu,nclu)
+ length.fun<-length(fun)
+ }
+
+
+ if(save.err.v||sameModel) {
+ if(nr==1){
+ fun<-c(fun,"ERR.V<-array(NA,dim=c(",n.types,",",k[1],",",k[2],"),dimnames = list(",paste("c('",paste(blocks,collapse="','"),"')",sep=""),",NULL,NULL))\n") #,dimnames=list(nclu,nclu,all.block.types)
+ }else{
+ if(sameModel){
+ fun<-c(fun,"ERR.V<-array(NA,dim=c(",n.types[1],",",k[1],",",k[2],",",nr,"))\n") #,dimnames=list(nclu,nclu,all.block.types)
+ }else{
+ fun<-c(fun,"ERR.V<-list(array(NA,dim=c(",n.types[1],",",k[1],",",k[2],"),dimnames = list(",paste("c('",paste(blocks[[1]],collapse="','"),"')",sep=""),",NULL,NULL))\n") #,dimnames=list(nclu,nclu,all.block.types)
+ for(i in 2:nr){
+ fun<-c(fun,"ERR.V<-c(ERR.V,list(array(NA,dim=c(",n.types[i],",",k[1],",",k[2],"),dimnames = list(",paste("c('",paste(blocks[[i]],collapse="','"),"')",sep=""),",NULL,NULL))\n") #,dimnames=list(nclu,nclu,all.block.types)
+ }
+ }
+ }
+ if(changeT&&save.err.v) {
+ fun2<-c(fun2,"ERR.V<-res.old$ERR.V\n")
+ length.fun<-length(fun)
+ }
+ }
+
+ if(nr>1){
+ if(length(FUN)==1) FUN<-rep(list(FUN),times=nr)
+ if(length(approach)==1) approach<-rep(approach,times=nr)
+ if(length(m)==1) m<-rep(m,times=nr)
+ if(length(normbym)==1) normbym<-rep(normbym,times=nr)
+ if(length(norm)==1) norm<-rep(norm,times=nr)
+ if(length(cut)==1) cut<-rep(cut,times=nr)
+ if(length(max.con.val)==1) max.con.val<-rep(max.con.val,times=nr)
+ }
+
+
+ if(any(approach=="imp")){
+ if(is.null(m)) m<-rep(1,times=length(approach))
+ m[approach=="imp"]<-"max"
+ approach[approach=="imp"]<-"val"
+ print(m)
+ }
+
+ if(any(approach %in% c("ad","ss"))){
+ if(any(approach == "ss")){
+ fun<-c(fun,"dev<-function(x)sum((x-mean(x))^2)\n")
+ fun<-c(fun,"idev<-function(x)(x-mean(x))^2\n")
+ if(is.null(CV.use)){
+ fun<-c(fun,"dev.cv<-function(x,cv)sum((x-cv)^2)\n")
+ fun<-c(fun,"idev.cv<-function(x,cv)(x-cv)^2\n")
+ }else{
+ fun<-c(fun,"dev.cv<-function(x,cv,use='fixed'){cv<-switch(use,min=max(cv,mean(x)),max=min(cv,mean(x)),fixed=cv,free=mean(x));sum((x-cv)^2)}\n")
+ fun<-c(fun,"idev.cv<-function(x,cv,use='fixed'){cv<-switch(use,min=max(cv,mean(x)),max=min(cv,mean(x)),fixed=cv,free=mean(x));(x-cv)^2}\n")
+ }
+ fun<-c(fun,"cv<-mean\n")
+ } else{
+ fun<-c(fun,"dev<-function(x)sum(abs(x-median(x)))\n")
+ fun<-c(fun,"idev<-function(x)abs(x-median(x))\n")
+ if(is.null(CV.use)){
+ fun<-c(fun,"idev.cv<-function(x,cv)abs(x-cv)\n")
+ fun<-c(fun,"dev.cv<-function(x,cv)sum(abs(x-cv))\n")
+ }else{
+ fun<-c(fun,"dev.cv<-function(x,cv,use='fixed'){cv<-switch(use,min=max(cv,median(x)),max=min(cv,median(x)),fixed=cv);sum((x-cv)^2)}\n")
+ fun<-c(fun,"idev.cv<-function(x,cv,use='fixed'){cv<-switch(use,min=max(cv,median(x)),max=min(cv,median(x)),fixed=cv);(x-cv)^2}\n")
+ }
+ fun<-c(fun,"cv<-median\n")
+ }
+ approach[approach %in% c("ad","ss")]<-"hom"
+ if(any(normbym[approach %in% c("ad","ss")])) {
+ normbym[approach %in% c("ad","ss")]<-FALSE
+ warning("'normbym' can be only used for valued ('val') and implicit ('imp') apporach")
+ }
+ }
+
+ #### for binary approach
+ if(any(approach=="bin")){
+ if(nr==1){
+ if(!all(blocks%in%bin.all.ideal.blocks)) stop("The block(s)",blocks[!blocks%in%bin.all.ideal.blocks] ," is (are) not defined!")
+ bM <- (M>=cut)+0
+ }else {
+ for(iblocks in blocks[approach=="bin"]){
+ if(!all(iblocks%in%bin.all.ideal.blocks)) stop("The block(s)",blocks[!blocks%in%bin.all.ideal.blocks] ," is (are) not defined!")
+ }
+ bM <- M
+ for(i in 1:nr) bM[,,i]<-(M[,,i]>=cut[i])+0
+ }
+
+ assign(x="bM",value=bM,envir=parent.frame())
+ if("den"%in% unlist(blocks)) fun<-c(fun,"dn<-",dn,"\n")
+ if(any(normbym[approach=="bin"])) {
+ normbym[approach=="bin"]<-FALSE
+ warning("'normbym' can be only used for valued ('val') and implicit ('imp') apporach")
+ }
+ }
+
+
+ #### for valued approach
+ if(any(approach=="val")){
+ if(is.null(m))stop("m must be specified for valued blockmodeling")
+ if(nr==1){
+ if(!all(blocks%in%val.all.ideal.blocks)) stop("The block(s)",blocks[!blocks%in%val.all.ideal.blocks] ," is (are) not defined!")
+ }else {
+ for(iblocks in blocks[approach=="val"])
+ if(!all(iblocks%in%val.all.ideal.blocks)) stop("The block(s)",blocks[!blocks%in%val.all.ideal.blocks] ," is (are) not defined!")
+ }
+
+
+ if(any(max.con.val!="non")){
+ if(nr==1){
+ if(max.con.val=="m")max.con.val<-m
+ if(max.con.val=="s")max.con.val<-s
+ if(!is.numeric(max.con.val))stop('"max.con.val" must me numeric or a strig with a value "m", "s" or "non"!')
+
+ M[M>max.con.val]<-max.con.val
+ M[M<(-max.con.val)]<- (-max.con.val)
+ }else{
+ for(i in 1:nr){
+ tmax.con.val<-max.con.val[i]
+ if(tmax.con.val=="m")tmax.con.val<-m[i]
+ if(tmax.con.val=="s")tmax.con.val<-s[i]
+ tmax.con.val<-as.numeric(tmax.con.val)
+ if(is.na(tmax.con.val))stop('"max.con.val" must me numeric or a strig with a value "m", "s" or "non"!')
+ Mi<-M[,,i]
+ Mi[Mi>tmax.con.val]<-tmax.con.val
+ Mi[Mi<(-tmax.con.val)]<- (-tmax.con.val)
+ Mi->M[,,i]
+ }
+ }
+ }
+
+ misfun<-!grepl(pattern="^[1234567890]+$",x=m)
+ mfun<-m
+
+ # fun<-c(fun,"m <- ",m,"\n")
+ if("avg"%in% unlist(blocks)) fun<-c(fun,"av<-",av,"\n")
+ }else{
+ misfun<-NULL
+ mfun<-NULL
+ }
+
+ assign(x="useM",value=M,envir=parent.frame())
+
+
+
+ if(nr>1){
+# Lm<-m
+ LFUN<-FUN
+ Lcut<-cut
+ LBLOCKS<-BLOCKS
+ Lblocks<-blocks
+ Lmfun<-mfun
+ Lapproach<-approach
+ Lnormbym<-normbym
+ Lnorm<-norm
+ LBLOCKS.CV<-BLOCKS.CV
+ LCV.use<-CV.use
+ Lmisfun<-misfun
+ }
+
+
+ if(!is.null(m)){
+ assign(x="exm",value=m,envir=parent.frame())
+ if(nr>1) fun<-c(fun,"Lm<-m\n")
+ }
+
+
+ for(i1 in 1:k[1]){
+ for(i2 in if(directed){1:k[2]}else{1:i1}){
+ for(inr in seq(length=nr)){
+ if(nmode<=2||{cl<-cut(c(i1,i2),breaks=c(0,cumsum(kmode))+0.5,labels=FALSE);cl[1]!=cl[2]}){
+ if(nr>1){
+# Lm[inr]->m
+ if(!is.null(m)) fun<-c(fun,"m<-Lm[",inr,"]\n")
+ LFUN[[inr]]->FUN
+ Lcut[inr]->cut
+ LBLOCKS[[inr]]->BLOCKS
+ LBLOCKS.CV[[inr]]->BLOCKS.CV
+ LCV.use[[inr]]->CV.use
+ Lblocks[[inr]]->blocks
+ Lmisfun[inr]->misfun
+ Lmfun[inr]->mfun
+ Lapproach[inr]->approach
+ Lnormbym[inr]->normbym
+ Lnorm[inr]->norm
+ }
+ if(changeT) {
+ fun2<-c(fun2,fun[-(1:length.fun)],"if(any(c(",if(nmode==2)c("if(modechange==1) ",i1," else ",i2) else c(i1,",",i2),") %in% change)){\n")
+ length.fun<-length(fun)
+ }
+
+
+ if(approach=="bin"){
+ fun<-c(fun,"B<-bM[clu",if(nmode==2) "[[1]]" else NULL,"==",i1,",clu",if(nmode==2) "[[2]]" else NULL,"==",i2,if(nr>1) c(",",inr) else NULL,",drop=FALSE]\n")
+ fun<-c(fun,"nr<-dim(B)[1]\n") #numer of rows
+ fun<-c(fun,"nc<-dim(B)[2]\n") #numer of colums
+ #if(any(c("null","com","rdo","cdo","reg","rre","cre","rfn","cfn","den","dnc") %in% BLOCKS[,i1,i2]))
+ #if(any(c("reg","rre","cre") %in% BLOCKS[,i1,i2])&i1==i2&diag®DiagSep)fun<-c(fun,"Bd<-B\ndiag(Bd)<-0\n")
+ if(any(c("null","com","rfn","cfn","den") %in% BLOCKS[,i1,i2])) fun<-c(fun,"st<-sum(B)\n")
+ if(any(c("reg","rdo","rre","rfn") %in% BLOCKS[,i1,i2])) fun<-c(fun,"sr<-rowSums(B)\n")
+ if(any(c("reg","cdo","cre","rfn") %in% BLOCKS[,i1,i2])) fun<-c(fun,"sc<-colSums(B)\n")
+ if(any(c("reg","rre","rfn") %in% BLOCKS[,i1,i2])) fun<-c(fun,"pr<-sum(sr>0)\n")
+ if(any(c("reg","cre","rfn") %in% BLOCKS[,i1,i2])) fun<-c(fun,"pc<-sum(sc>0)\n")
+ } else {
+ fun<-c(fun,"B<-M[clu",if(nmode==2) "[[1]]" else NULL,"==",i1,",clu",if(nmode==2) "[[2]]" else NULL,"==",i2,if(nr>1) c(",",inr) else NULL,",drop=FALSE]\n")
+ #if(any(c("reg","rre","cre") %in% BLOCKS[,i1,i2])&i1==i2&diag®DiagSep)fun<-c(fun,"Bd<-B\ndiag(Bd)<-0\n")
+ }
+ fun<-c(fun,"dim(B)<-dim(B)[1:2]\n")
+
+ fun<-c(fun,"nr<-dim(B)[1]\n") #numer of rows
+ fun<-c(fun,"nc<-dim(B)[2]\n") #numer of colums
+
+ if(approach=="val"){
+ if(normbym) fun<-c(fun,"if(max(B)!=0){\n")
+ #if(any(c("null","com","rdo","cdo","reg","rre","cre","rfn","cfn","den","dnc") %in% BLOCKS[,i1,i2]))
+ if(misfun){
+ fun<-c(fun,"m<-do.call(",mfun,",list(B))\n")
+ if(!allow.max0) fun<-c(fun,"if(m==0)m<-do.call(",mfun,",list(M",if(nr>1) c("[,,",inr,"]") else NULL,"))\n")
+ }
+
+ #if(any(c("com","reg","rre","cre","rdo","cdo","rfn","cfn","avg") %in% BLOCKS[,i1,i2]) || norm || (i1==i2 && diag)) fun<-c(fun,"nr<-dim(B)[1]\n") #numer of rows
+ #if(any(c("com","reg","rre","cre","rdo","cdo","rfn","cfn","avg") %in% BLOCKS[,i1,i2]) || norm) fun<-c(fun,"nc<-dim(B)[2]\n") #numer of colums
+ if(any(c("null","rfn","cfn","avg") %in% BLOCKS[,i1,i2])) fun<-c(fun,"sumB<-sum(B)\n")
+
+
+ if(any(c("reg","rre") %in% BLOCKS[,i1,i2])) fun<-c(fun,"sr<-apply(B,1,",FUN,")\n",
+ "er<-m-sr",if(!misfun) c("[sr<m]") else NULL,"\n", #row errors for regular blocks
+ "pr <- sum(sr>0)\n")
+
+ if(any(c("reg","cre") %in% BLOCKS[,i1,i2])) fun<-c(fun,"sc<-apply(B,2,",FUN,")\n",
+ "ec<-m-sc",if(!misfun) c("[sc<m]") else NULL,"\n", #column errors for regular blocks
+ "pc <- sum(sc>0)\n")
+
+ if("rfn" %in% BLOCKS[,i1,i2]) {
+ if(any(c("reg","rre") %in% BLOCKS[,i1,i2]) && FUN=="max"){
+ fun<-c(fun,"srm<-sr\n")
+ }else fun<-c(fun,"srm<-apply(B,1,max)\n")
+ }
+ if((c("cfn") %in% BLOCKS[,i1,i2])) {
+ if(any(c("reg","cre") %in% BLOCKS[,i1,i2]) && FUN=="max"){
+ fun<-c(fun,"scm<-sc\n")
+ }else fun<-c(fun,"scm<-apply(B,2,max)\n")
+ }
+ }
+
+ if(approach == "hom"){
+ if(any(c("null","com") %in% BLOCKS[,i1,i2]) && diag && i1==i2) fun<-c(fun,"B2<-B\ndiag(B2)<-NA\n")
+ if(any(c("reg","rre","cre") %in% BLOCKS[,i1,i2]) && i1==i2 && diag && regDiagSep)fun<-c(fun,"Bd<-B\ndiag(Bd)<-0\n")
+ #fun<-c(fun,"nr<-dim(B)[1]\n") #numer of rows
+ #fun<-c(fun,"nc<-dim(B)[2]\n") #numer of colums
+ }
+
+ fun<-c(fun,"err<-numeric()\n")
+
+
+
+ for(iEq in 1:dim(BLOCKS)[1]){
+ eq=BLOCKS[iEq,i1,i2]
+ if(!is.na(eq)){
+ if(approach=="bin") fun<-c(fun, switch(EXPR=eq,
+ "null" = c("err['",eq,"'] <-", "st","\n"),
+ "com" = c("err['",eq,"'] <-", "nc*nr-st","\n"),
+ "rdo" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL , "(nc - max(sr))*nr","\n"),
+ "cdo" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL , "(nr - max(sc))*nc","\n"),
+ "reg" = c("err['",eq,"'] <-",if(mindimreg&mindim>1)"if(nc<mindim|nr<mindim) Inf else " else NULL , "((nc-pc)*nr+(nr-pr)*pc)","\n"),
+ "rre" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL , "(nr-pr)*nc","\n"),
+ "cre" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL , "(nc-pc)*nr","\n"),
+ "rfn" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL , "st - pr + (nr - pr)*nc","\n"),
+ "cfn" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL , "st - pc + (nc - pc)*nr","\n"),
+ "den" = c("err['",eq,"'] <-", "max(0,dn*nr*nc-st)","\n"),
+ "dnc" = c("err['",eq,"'] <-", "0","\n")
+ ))
+
+ if(approach=="val") fun<-c(fun, switch(EXPR=eq,
+ "null" = c("err['",eq,"'] <-", "sumB",if(normbym) "/m","\n"),
+ "com" = c("err['",eq,"'] <-", "sum(m-B[B<m])",if(normbym) "/m","\n"),
+ "rdo" = c(if(mindim>1) c("if(nr<mindim) err['",eq,"'] <-Inf else"),"{",if(misfun) c("mr<-apply(B,1,",mfun,")\n", if(!allow.dom0) c("mr[mr==0]<-m\n")),"err['",eq,"'] <- min(",if(normbym)"(" else NULL,"apply(",if(misfun) c("rep(mr,times=nc) - B,1,sum)*nr") else c("m - B,1,sumpos)*nr"),if(diag && i1==i2){c(" + useneg(sum(diag(B))*nr - ",if(misfun) "(diag(mr - B))*nr)" else c("usepos(diag(m - B))*nr)"))} else NULL,if(normbym) {if(misfun) {if(allow.dom0)")/{mr[mr==0]<-1;mr})" else ") [...]
+ "cdo" = c(if(mindim>1) c("if(nc<mindim) err['",eq,"'] <-Inf else"),"{",if(misfun) c("mc<-apply(B,2,",mfun,")\n", if(!allow.dom0) c("mc[mc==0]<-m\n")),"err['",eq,"'] <- min(",if(normbym)"(" else NULL,"apply(",if(misfun) c("rep(mc,each =nr) - B,2,sum)*nc") else c("m - B,2,sumpos)*nc"),if(diag && i1==i2){c(" + useneg(sum(diag(B))*nc - ",if(misfun) "(diag(mc - B))*nc)" else c("usepos(diag(m - B))*nc)"))} else NULL,if(normbym) {if(misfun) {if(allow.dom0)")/{mc[mc==0]<-1;mc})" else ") [...]
+ "reg" = c("err['",eq,"'] <-",if(mindimreg&mindim>1)"if(nc<mindim|nr<mindim) Inf else " else NULL , if(normbym)"("else NULL, "sum(er)*nc+ sum(ec)*nr - sum(pmin(rep(er,times=length(ec)),rep(ec,each=length(er))))",if(normbym) ")/m","\n"),
+ "rre" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL , "sum(er)*nc",if(normbym) "/m","\n"),
+ "cre" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL , "sum(ec)*nr",if(normbym) "/m","\n"),
+ "rfn" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL , if(normbym)"("else NULL, "sumB- sum(srm) + sumpos(m - srm)*nc",if(normbym) "/m","\n"),
+ "cfn" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL , if(normbym)"("else NULL, "sumB- sum(scm) + sumpos(m - scm)*nr",if(normbym) "/m","\n"),
+ "avg" = c("err['",eq,"'] <-", "max(0,av*nr*nc-sumB)", if(normbym) "/m", "\n"),
+ "dnc" = c("err['",eq,"'] <-", "0","\n")
+ ))
+
+ if(approach=="hom") {
+ if(is.null(BLOCKS.CV)) {
+ #cat("i1 = ", i1,", i2 = ",i2,",diag = ",diag,", regDiagSep = ", regDiagSep,", diag && i1==i2 && regDiagSep = ", diag && i1==12 && regDiagSep, "\n",sep="")
+ fun<-c(fun, switch(EXPR=eq,
+ "null" = c("err['",eq,"'] <-",if(diag && i1==i2)"if(nr>=2) dev.cv(na.omit(as.vector(B2)),cv=0) + dev(diag(B)) else dev.cv(B,cv=0)" else "dev.cv(B,cv=0)","\n"),
+ "com" = c("err['",eq,"'] <-",if(diag && i1==i2)"if(nr>=2) dev(na.omit(as.vector(B2))) + dev(diag(B)) else 0" else "dev(B)","\n"),
+ "rdo1" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL ,if(diag && i1==i2)"min(","{tmp<-apply(B,1,cv);tmp<-idev(tmp);min(apply(B,1,dev)[which(tmp==max(tmp))])}*nc",if(diag && i1==i2)",min((apply(B2,1,function(x)dev(na.omit(x)))+idev(diag(B)))[which(tmp==max(tmp))])*nc)","\n"),
+ "cdo1" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL ,if(diag && i1==i2)"min(","{tmp<-apply(B,2,cv);tmp<-idev(tmp);min(apply(B,2,dev)[which(tmp==max(tmp))])}*nr",if(diag && i1==i2)",min((apply(B2,2,function(x)dev(na.omit(x)))+idev(diag(B)))[which(tmp==max(tmp))])*nr)","\n"),
+ "rdo2" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL ,if(diag && i1==i2)"min(","min(apply(B,1,dev))*nc",if(diag && i1==i2)",min((apply(B2,1,function(x)dev(na.omit(x)))+idev(diag(B))))*nc)","\n"),
+ "cdo2" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL ,if(diag && i1==i2)"min(","min(apply(B,2,dev))*nr",if(diag && i1==i2)",min((apply(B2,2,function(x)dev(na.omit(x)))+idev(diag(B))))*nr)","\n"),
+ "rdo3" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL ,if(diag && i1==i2)"min(","{tmp<-apply(B,1,cv);min(apply(B,1,dev)[which(tmp==max(tmp))])}*nc",if(diag && i1==i2)",min((apply(B2,1,function(x)dev(na.omit(x)))+idev(diag(B)))[which(tmp==max(tmp))])*nc)","\n"),
+ "cdo3" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL ,if(diag && i1==i2)"min(","{tmp<-apply(B,2,cv);min(apply(B,2,dev)[which(tmp==max(tmp))])}*nr",if(diag && i1==i2)",min((apply(B2,2,function(x)dev(na.omit(x)))+idev(diag(B)))[which(tmp==max(tmp))])*nr)","\n"),
+ "rfn" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL ," {tmp<-apply(B,1,max);dev(tmp)+dev.cv(B,cv=0)-dev.cv(tmp,cv=0)}","\n"),
+ "cfn" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL ," {tmp<-apply(B,2,max);dev(tmp)+dev.cv(B,cv=0)-dev.cv(tmp,cv=0)}","\n"),
+ "reg" = c("err['",eq,"'] <-",if(mindimreg&mindim>1)"if(nc<mindim|nr<mindim) Inf else " else NULL,if(!(diag && i1==i2 && regDiagSep)){
+ c("max(dev(apply(B,1,",FUN,"))*nc,dev(apply(B,2,",FUN,"))*nr)" )
+ } else c("max(dev(apply(Bd,1,",FUN,"))*(nc-1),dev(apply(Bd,2,",FUN,"))*(nr-1))+ss(dev(diag(B)))" ),"\n"),
+ "rre" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL , if(!(diag && i1==i2 && regDiagSep)){
+ c("dev(apply(B,1,",FUN,"))*nc")
+ }else c("dev(apply(Bd,1,",FUN,"))*(nc-1)+dev(diag(B))"),"\n") ,
+ "cre" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL , if(!(diag && i1==i2 && regDiagSep)){
+ c("dev(apply(B,2,",FUN,"))*nr")
+ } else c("dev(apply(Bd,2,",FUN,"))*(nr-1) + dev(diag(B))"),"\n"),
+ "dnc" = c("err['",eq,"'] <-", "0","\n")
+ ))
+ }else{
+ UseNotNull<-!is.null(CV.use)
+ fun<-c(fun, switch(EXPR=eq,
+ "null" = c("err['",eq,"'] <-",if(diag && i1==i2)"if(nr>=2) dev.cv(na.omit(as.vector(B2)),cv=0) + dev(diag(B)) else dev.cv(B,cv=0)" else "dev.cv(B,cv=0)","\n"),
+ "com" = c("err['",eq,"'] <-",if(diag && i1==i2) c("if(nr>=2) dev.cv(na.omit(as.vector(B2)),cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull)c(", use=CV.use[",iEq,",",i1,",",i2,"]"),") + dev(diag(B)) else dev.cv(B,cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull)c(", use=CV.use[",iEq,",",i1,",",i2,"]"),")") else c("dev.cv(B,cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull)c(", use=CV.use[",iEq,",",i1,",",i2,"]"),")"),"\n"),
+ "reg" = c("err['",eq,"'] <-",if(mindimreg&mindim>1)"if(nc<mindim|nr<mindim) Inf else " else NULL,if(!(diag && i1==i2 && regDiagSep)){
+ c("max(dev.cv(apply(B,1,",FUN,"),cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull) c(", use=CV.use[",iEq,",",i1,",",i2,"]")else NULL,")*nc,dev.cv(apply(B,2,",FUN,"),cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull)c(", use=CV.use[",iEq,",",i1,",",i2,"]")else NULL,")*nr)" ,"\n")
+ } else c("max(dev.cv(apply(Bd,1,",FUN,"),cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull) c(", use=CV.use[",iEq,",",i1,",",i2,"]")else NULL,")*(nc-1),dev.cv(apply(Bd,2,",FUN,"),cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull)c(", use=CV.use[",iEq,",",i1,",",i2,"]")else NULL,")*(nr-1))+ss(dev(diag(B)))" ,"\n")),
+ "rre" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL , if(!(diag && i1==i2 && regDiagSep)){
+ c("dev.cv(apply(B,1,",FUN,"),cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull) c(", use=CV.use[",iEq,",",i1,",",i2,"]") else NULL,")*nc","\n")
+ } else c("dev.cv(apply(Bd,1,",FUN,"),cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull) c(", use=CV.use[",iEq,",",i1,",",i2,"]")else NULL,")*(nc-1)+dev(diag(B))","\n")),
+ "cre" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL , if(!(diag && i1==i2 && regDiagSep)){
+ c("dev.cv(apply(B,2,",FUN,"),cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull) c(", use=CV.use[",iEq,",",i1,",",i2,"]")else NULL,")*nr","\n")
+ } else c("dev.cv(apply(Bd,2,",FUN,"),cv=BLOCKS.CV[",iEq,",",i1,",",i2,"]",if(UseNotNull) c(", use=CV.use[",iEq,",",i1,",",i2,"]")else NULL,")*(nr-1)+dev(diag(B))","\n")) ,
+ "dnc" = c("err['",eq,"'] <-", "0","\n")
+ ))
+ }
+ }
+ }
+ }
+
+ if(diag && i1==i2 && any(c("null","com","rdo","cdo") %in% BLOCKS[,i1,i2])){
+ if(approach=="bin"){
+ fun<-c(fun,"if(nr>=2){\n")
+ fun<-c(fun,"sd<-sum(diag(B))\n")
+ fun<-c(fun,"d.err.null<-(nr - 2*sd)\n")
+ for(eq in BLOCKS[,i1,i2]){
+ if(!is.na(eq)){
+ fun<-c(fun,switch(EXPR=eq,
+ "null" = c("err['",eq,"'] <-", "err['",eq,"']"," + min(0,d.err.null)","\n"),
+ "com" = c("err['",eq,"'] <-", "err['",eq,"']"," + min(0,-d.err.null)","\n"),
+ "rdo" = c("err['",eq,"'] <-",if(mindim>1)"if(nr<mindim) Inf else " else NULL , "err['",eq,"']"," - ifelse(sd==0,nc,0)","\n"),
+ "cdo" = c("err['",eq,"'] <-",if(mindim>1)"if(nc<mindim) Inf else " else NULL , "err['",eq,"']"," - ifelse(sd==0,nr,0)","\n")
+ ))
+ }
+ }
+ fun<-c(fun,"}\n")
+ }
+
+ if(any(c("null","com") %in% BLOCKS[,i1,i2])){
+ if(approach=="val"){
+ fun<-c(fun,"if(nr>=2){\n")
+ fun<-c(fun,"d.err.com<- (sum(diag(B))-sumpos(m-diag(B)))\n")
+ for(eq in BLOCKS[,i1,i2]){
+ if(!is.na(eq)){
+ fun<-c(fun,switch(EXPR=eq,
+ "null" = c("err['",eq,"'] <-", "err['",eq,"']"," + min(0,-d.err.com)", if(normbym)"/m","\n"),
+ "com" = c("err['",eq,"'] <-", "err['",eq,"']"," + min(0,d.err.com)", if(normbym)"/m", "\n")
+ ))
+ }
+ }
+ fun<-c(fun,"}\n")
+ }
+ }
+ }
+
+
+
+
+ if(use.weights) fun<-c(fun,"err<-err*blockWeights",if(nr>1)c("[[",inr,"]]") else NULL,"[names(err)]\n")
+ if(norm) fun<-c(fun,"err<-err/nr/nc\n")
+ if(approach=="val"&& normbym) {
+ fun<-c(fun,"} else {\nerr<-numeric()\nerr[",paste("c('",paste(BLOCKS[,i1,i2],sep="",collapse="','"),"')",sep=""),"]<-",if(allow.max0) "0" else "1" ,"\nif('null' %in% ",paste("c('",paste(BLOCKS[,i1,i2],sep="",collapse="','"),"')",sep=""),") err['null']<-0\n",if(!norm)"err<-err*nr*nc\n" else NULL,"}\n")
+ }
+
+
+ if(save.err.v && !sameModel) {
+ fun<-c(fun,"ERR.V",if(nr>1)c("[[",inr,"]]") else NULL,"[,",i1,",",i2,"]<- err[BLOCKS",if(nr>1)c("[[",inr,"]]") else NULL,"[,",i1,",",i2,"]]\n")
+ }
+
+ fun<-c(fun,"if(length(err)==0) err['non']<-Inf \n")
+
+ if(sameModel){
+ fun<-c(fun,"ERR.V[,",i1,",",i2,",",inr,"]<- err[BLOCKS",if(nr>1)c("[[",inr,"]]") else NULL,"[,",i1,",",i2,"]]\n")
+ if(!directed) fun<-c(fun,"ERR.V[,",i2,",",i1,",",inr,"]<- err[BLOCKS",if(nr>1)c("[[",inr,"]]") else NULL,"[,",i2,",",i1,"]]\n")
+ }else{
+ fun<-c(fun,"E[",i1,",",i2,if(nr>1)c(",",inr)else NULL,"]<-min(err)\n")
+ fun<-c(fun,"IM[",i1,",",i2,if(nr>1)c(",",inr)else NULL,"]<-names(which(err==min(err))[1])\n")
+ }
+
+
+ if(changeT){
+ fun2<-c(fun2,fun[-(1:length.fun)],"}\n")
+ length.fun<-length(fun)
+ }
+
+
+ }
+
+ }
+ }
+ }
+
+
+ if(!directed && !sameModel){
+ if(nr==1){
+ fun<-c(fun,"E[upper.tri(E)]<-t(E)[upper.tri(E)]\nIM[upper.tri(IM)]<-t(IM)[upper.tri(IM)]\n")
+ }else{
+ for(inr in 1:nr){
+ fun<-c(fun,"E[,,",inr,"][upper.tri(E[,,",inr,"])]<-t(E[,,",inr,"])[upper.tri(E[,,",inr,"])]\nIM[,,",inr,"][upper.tri(IM[,,",inr,"])]<-t(IM[,,",inr,"])[upper.tri(IM[,,",inr,"])]\n")
+ }
+ }
+ }
+
+ if(sameModel){
+ fun<-c(fun,"allE<-apply(ERR.V,c(1,2,3),function(x)sum(x*c(",paste(relWeights,collapse=","),")))
+ oneE<-apply(allE,c(2,3),min,na.rm=TRUE)
+ oneEarray<-array(NA,dim=c(",n.types[1],",",k[1],",",k[2],"))\n")
+ for(idim in 1:n.types[1]) fun<-c(fun,"oneEarray[",idim,",,]<-oneE\n")
+ fun<-c(fun,"oneIM<-apply(allE==oneEarray,c(2,3),function(x)which(x)[1])\n")
+ fun<-c(fun,"for(inr in 1:",nr,"){
+ for(i1 in 1:",k[1],"){
+ for(i2 in 1:",k[2],"){
+ E[i1,i2,inr]<-ERR.V[oneIM[i1,i2],i1,i2,inr]
+ IM[i1,i2,inr]<-BLOCKS[[inr]][oneIM[i1,i2],i1,i2]
+ }
+ }
+ }\n")
+ if(!is.null(positionWeights))fun<-c(fun,"oneE<-oneE*positionWeights\n")
+ fun<-c(fun,"totalErr<-sum(oneE)\n")
+ } else {
+ if(nr>1){
+ fun<-c(fun,"oneE<-apply(E,c(1,2),function(x)sum(x*c(",paste(relWeights,collapse=","),")))\n")
+ if(!is.null(positionWeights))fun<-c(fun,"oneE<-oneE*positionWeights\n")
+ fun<-c(fun,"totalErr<-sum(oneE)\n")
+ }else {
+ if(!is.null(positionWeights))fun<-c(fun,"E<-E*positionWeights\n")
+ fun<-c(fun,"totalErr<-sum(E)\n")
+ }
+ }
+
+ if(normMto2rel&sameModel){
+ fun<-c(fun,"oneIM<-IM[,,1]\n")
+ if(normMto2relRegToRreCre)fun<-c(fun,"oneIM[oneIM=='rre']<-'reg'\n")
+ }
+
+ fun<-c(fun,"return(list(err=totalErr,clu=clu,E=E,IM=",if(normMto2rel&sameModel)"oneIM" else "IM",",approach=approach,normMto2rel=",normMto2rel,if(sameModel){if(normMto2rel) ",completeIM = IM" else ",oneIM=oneIM"},if(nr>1)",oneE=oneE" else NULL, if(save.err.v)",ERR.V=ERR.V" else NULL ,"))\n")
+ if(changeT){
+ fun2<-c(fun2,fun[-(1:length.fun)],"}\n")
+ fun<-c(fun,"}\n")
+# cat(file="fun1.R",fun,sep="")
+# cat(file="fun2.R",fun2,sep="")
+ return(list(fun1= parse(text=paste(fun,sep="",collapse="")),fun2 = parse(text=paste(fun2,sep="",collapse=""))))
+ } else {
+ fun<-c(fun,"}\n")
+# cat(file="fun1.R",fun,sep="")
+ return(parse(text=paste(fun,sep="",collapse="")))
+ }
+ }
+}
diff --git a/R/gen.opt.par.R b/R/gen.opt.par.R
new file mode 100644
index 0000000..65f10db
--- /dev/null
+++ b/R/gen.opt.par.R
@@ -0,0 +1,265 @@
+"gen.opt.par" <-
+function(
+ #function for optimizig partition in blockmodeling
+ M, #matrix
+ k, #number partitions for each mode
+# e1, #weight of the error of binearized matrix
+# e2, #weight of the error of valued conenctions
+ approach,
+ ..., #other arguments to called functions - to 'crit.fun'
+ #m, #suficient value individual cells
+ maxiter, #maximum number of iterations
+ mingr=1, #minimal alowed group size
+ maxgr=Inf, #maximal alowed group size
+# s="default", #suficient value for colum and row statistics
+# FUN, #function to calculate row and colum statistics
+# blocks#=c("null","com","reg"), #permissible block types and their ordering
+# BLOCKS=NULL, #array of permissible block types and their ordering for all blocks
+# mindim = 2, #minimal dimension for regulal, dominant and functional blocks
+# save.err.v=FALSE, #save a vector of errors of all block types for all blocks
+ trace.iter, #save a result of each iteration or only the best (minimal error)
+ switch.names, #should partitions that only differ in group names be considert equal (is c(1,1,2)==c(2,2,1))
+ save.initial.param, #should the initial parameters be saved
+ skip.par, #the partions that are not allowed or were already checked and should be skiped
+ save.checked.par, #should the checked partitions be saved
+ merge.save.skip.par, #should the checked partitions be merged with skiped ones
+ parOK = NULL, # a function that takes the partition as the argument and retutns TRUE, it partition is ok (satisfies the all conditions)
+ parOKaddParam = NULL, # additional parameters for function "partOK"
+ check.skip, #when should the check be preformed:
+ # "all" - before every call to 'crit.fun'
+ # "iter" - at the end of eack iteratiton
+ # "opt.par" - before every call to 'opt.par', implemented in opt.these.par and opt.random.par
+ # "never" - never
+ print.iter=TRUE,
+ check.switch=TRUE,
+ check.all=TRUE,
+ use.for.opt=TRUE
+# force.fun=NULL, #select the function used to evaluate partition
+){
+ dots<-list(...)
+ nmode<-length(k)
+ notUseNormMto2rel<-is.null(dots$normMto2rel)||!dots$normMto2rel
+ if(approach=="ss"&&all(dots$blocks=="com")&& all(dots$BLOCKS=="com")&&nmode==1&&use.for.opt&¬UseNormMto2rel){
+ fun<-c("opt.par.tmp<-function(M=M,clu=clu,diag=TRUE,...){
+ maxiter<-",maxiter,"
+ n<-dim(M)[1]
+ clu<-as.integer(factor(clu))
+ k<-max(clu)
+ M[,]<-as.double(M)
+ res<-.Fortran('optparsscom',M=M,clu=clu,diag=diag,maxiter=as.integer(maxiter),n=as.integer(dim(M)[1]),k=k,err=as.double(0),E=diag(k)*as.double(0),BM=diag(k)*as.double(0),cluM=matrix(as.integer(0),nrow=50,ncol=dim(M)[1]),nbest=as.integer(0),iter=as.integer(0),printIter=",print.iter,")
+ best1<-res[c(2,7,8,9)]
+ IM<-best1$E
+ IM[,] <- 'com'
+ best1$IM<-IM
+ res<-list(M=res$M,best=c(list(best1=best1), if(res$nbest>1) apply(res$cluM[seq(res$nbest),],1,function(x)list(clu=x))[-1]else NULL),nIter=res$iter)
+ class(res)<-'opt.par'
+ return(res)
+ }")
+# cat(fun,file="tmp.R")
+ return(parse(text=fun))
+ }
+
+ if(approach=="ss"&&all(dots$blocks=="com")&& all(dots$BLOCKS=="com")&&nmode==2&&use.for.opt&¬UseNormMto2rel&&length(dim(M))==2){
+ fun<-c("opt.par.tmp<-function(M=M,clu=clu,diag=TRUE,...){
+ maxiter<-",maxiter,"
+ n1<-dim(M)[1]
+ n2<-dim(M)[2]
+ clu1<-as.integer(factor(clu[[1]]))
+ clu2<-as.integer(factor(clu[[2]]))
+ k1<-max(clu1)
+ k2<-max(clu2)
+ M[,]<-as.double(M)
+ res<-.Fortran('optparsscomtm',M=M,clu1=clu1,clu2=clu2,maxiter=as.integer(maxiter),n1=as.integer(dim(M)[1]),n2=as.integer(dim(M)[2]),k1=k1,k2=k2,err=as.double(0),E=matrix(as.double(0),nrow=k1,ncol=k2),BM=matrix(as.double(0),nrow=k1,ncol=k2),cluM1=matrix(as.integer(0),nrow=50,ncol=dim(M)[1]),cluM2=matrix(as.integer(0),nrow=50,ncol=dim(M)[2]),nbest=as.integer(0),iter=as.integer(0),printIter=",print.iter,")
+ best1<-res[c('err','E','BM')]
+ best1$clu<-list(res$clu1,res$clu2)
+ IM<-best1$E
+ IM[,] <- 'com'
+ best1$IM<-IM
+ bestClus<-list()
+ if(res$nbest>1)for(i in 1:res$nbest){
+ bestClus<-c(bestClus,list(list(clu=list(res$cluM1[i,],res$cluM2[i,]))))
+ }
+ res<-list(M=res$M,best=c(list(best1=best1), if(res$nbest>1) bestClus),nIter=res$iter)
+ class(res)<-'opt.par'
+ return(res)
+ }")
+ fun<-paste(fun,collapse="")
+# cat(fun,file="tmp.R")
+ return(parse(text=fun))
+ }
+
+ if(approach=="ss"&&all(dots$blocks=="com")&& all(dots$BLOCKS=="com")&&nmode==2&&use.for.opt&¬UseNormMto2rel&&length(dim(M))==3){
+ fun<-c("opt.par.tmp<-function(M=M,clu=clu,diag=TRUE,...){
+ maxiter<-",maxiter,"
+ n1<-dim(M)[1]
+ n2<-dim(M)[2]
+ nr<-dim(M)[3]
+ clu1<-as.integer(factor(clu[[1]]))
+ clu2<-as.integer(factor(clu[[2]]))
+ k1<-max(clu1)
+ k2<-max(clu2)
+ M[,,]<-as.double(M)
+ res<-.Fortran('optparsscomtmmorerel',M=M,clu1=clu1,clu2=clu2,maxiter=as.integer(maxiter),nr=as.integer(dim(M)[3]),n1=as.integer(dim(M)[1]),n2=as.integer(dim(M)[2]),k1=k1,k2=k2,err=as.double(0),E=matrix(as.double(0),nrow=k1,ncol=k2),BM=array(as.double(0),dim=c(k1,k2,nr)),cluM1=matrix(as.integer(0),nrow=50,ncol=dim(M)[1]),cluM2=matrix(as.integer(0),nrow=50,ncol=dim(M)[2]),nbest=as.integer(0),iter=as.integer(0),printIter=",print.iter,")
+ best1<-res[c('err','E','BM')]
+ best1$clu<-list(res$clu1,res$clu2)
+ IM<-best1$E
+ IM[,] <- 'com'
+ best1$IM<-IM
+ bestClus<-list()
+ if(res$nbest>1)for(i in 1:res$nbest){
+ bestClus<-c(bestClus,list(list(clu=list(res$cluM1[i,],res$cluM2[i,]))))
+ }
+ res<-list(M=res$M,best=c(list(best1=best1), if(res$nbest>1) bestClus),nIter=res$iter)
+ class(res)<-'opt.par'
+ return(res)
+ }")
+ fun<-paste(fun,collapse="")
+# cat(fun,file="tmp.R")
+ return(parse(text=fun))
+ }
+
+
+
+
+ fun<-c("opt.par.tmp<-function(M=M,clu=clu,k=k,approach=approach,",if(!is.null(parOK)) "parOK=parOK, parOKaddParam = parOKaddParam,","...){\n")
+ if(save.initial.param) fun<-c(fun,"initial.param<-tryCatch(lapply(as.list(sys.frame(sys.nframe())),eval),error=function(...)return('error'))\n") #saves the inital parameters
+
+ fun<-c(fun," critfun<-gen.crit.fun(M=M,k=k,approach=approach,changeT=TRUE,...)
+
+ eval(critfun$fun1)\n")
+
+ if(trace.iter) {
+ fun<-c(fun,"best.crit.iter<-list(NULL)\n")
+ }#else best.crit.iter<-NULL
+
+
+ fun<-c(fun,"best.crit<-list(NULL)
+
+ res.last.iter<-best.crit[[1]]<-crit.fun.tmp(M=useM,clu)
+ eval(critfun$fun2)
+", if(save.checked.par) "checked.par<-list(clu)\n" else NULL,
+" iter<-0
+ imp<-TRUE
+
+ cat('Starting partition:',",if(nmode>1) "unlist(" else NULL, "clu",if(nmode>1) ")" else NULL, ",'\\n')
+ cat('Starting error:',best.crit[[1]]$err,'\\n\\n')
+
+
+ while((iter<maxiter)&imp){
+ imp<-FALSE
+ iter<-iter+1
+", " ", if(nmode==1) "tclu<-table(clu)" else "tclu<-lapply(clu,table)","\n",
+if(nmode>1)c(" for(imode in 1:nmode)",if(!check.all)"if(!imp)" else NULL,"{\n") else NULL,
+" for(i1 in ",if(nmode>2)"cumsum(c(0,k)[1:imode])+" else NULL,"1:k",if(nmode>1) "[[imode]]" else NULL, ")",if(!check.all)"if(!imp)" else NULL,"{
+ for(i2 in setdiff(",if(nmode>2)"cumsum(c(0,k)[1:imode])+" else NULL,"1:k",if(nmode>1) "[[imode]]" else NULL,",i1))",if(!check.all)"if(!imp)" else NULL,"{
+ for(i3 in 1:tclu",if(nmode>1) "[[imode]]" else NULL,"[i1])",if(!check.all)"if(!imp)" else NULL,"{
+ if(tclu",if(nmode>1) "[[imode]]" else NULL,"[i1]>",mingr,"&tclu",if(nmode>1) "[[imode]]" else NULL,"[i2]<",maxgr,") { #checkin if movement to another group improves criteria function
+ tempclu<-clu
+ tempclu",if(nmode>1) "[[imode]]" else NULL, "[tempclu",if(nmode>1) "[[imode]]" else NULL, "==i1][i3]<-i2
+", if(!is.null(parOK))"if(parOK(tempclu,parOKaddParam)){" else NULL ,if(check.skip=="all") c(" if(
+ ifelse(
+ is.null(skip.par),
+ TRUE,",
+ if(switch.names) c("
+ !any(sapply(skip.par,",if(nmode>1) "function(x,clu2)rand2(unlist(x),clu2)" else "rand2", ",clu2=",if(nmode>1) "unlist(" else NULL, "tempclu",if(nmode>1) ")" else NULL, ")==1)"
+ )else c("
+ !any(sapply(skip.par,function(x)all(",if(nmode>1) "unlist(" else NULL, "x",if(nmode>1) ")" else NULL, "==",if(nmode>1) "unlist(" else NULL, "tempclu",if(nmode>1) ")" else NULL, ")))"
+ ),"
+ )
+ ) #checking if the partition should be ignored
+ {
+") else NULL," temp.crit<-crit.fun.tmp(M=useM,clu=tempclu,change=c(i1,i2)",if(nmode==2) ", modechange=imode" else NULL, ",res.old=res.last.iter)
+
+ if(temp.crit$err<best.crit[[1]]$err) {
+ best.crit<-list(NULL)
+ best.crit[[1]]<-temp.crit
+ imp<-TRUE
+ } else if(temp.crit$err==best.crit[[1]]$err){
+ unique<-TRUE
+ for(i in 1:length(best.crit)){
+ ",if(switch.names){c(
+ "if(rand(table(",if(nmode>1) "unlist(" else NULL, "best.crit[[i]]$clu",if(nmode>1) ")" else NULL, ",",if(nmode>1) "unlist(" else NULL, "temp.crit$clu",if(nmode>1) ")" else NULL, "))==1) unique<-FALSE")
+ }else {c("
+ if(all(",if(nmode>1) "unlist(" else NULL, "best.crit[[i]]$clu",if(nmode>1) ")" else NULL, "==",if(nmode>1) "unlist(" else NULL, "temp.crit$clu",if(nmode>1) ")" else NULL, ")) unique<-FALSE")
+ },"
+ }
+ if(unique) {best.crit[[length(best.crit)+1]]<-temp.crit}
+ }
+", if(check.skip=="all") " }
+" else NULL,if(!is.null(parOK))"}" else NULL," }
+ ",if(check.switch)c("if(i1<i3){ #checkin if exchange of two units (from different groups) improves criteria function
+ for(i4 in 1:tclu",if(nmode>1) "[[imode]]" else NULL,"[i2])",if(!check.all)"if(!imp)" else NULL,"{
+ tempclu<-clu
+ tempclu",if(nmode>1) "[[imode]]" else NULL,"[clu",if(nmode>1) "[[imode]]" else NULL,"==i1][i3]<-i2
+ tempclu",if(nmode>1) "[[imode]]" else NULL,"[clu",if(nmode>1) "[[imode]]" else NULL,"==i2][i4]<-i1
+", if(!is.null(parOK))"if(parOK(tempclu,parOKaddParam)){" else NULL , if(check.skip=="all") c(" if(
+ ifelse(
+ is.null(skip.par),
+ TRUE,",
+ if(switch.names)c("
+ !any(sapply(skip.par,",if(nmode>1) "function(x,clu2)rand2(unlist(x),clu2)" else "rand2", ",clu2=",if(nmode>1) "unlist(" else NULL, "tempclu",if(nmode>1) ")" else NULL, ")==1)"
+ )else c("
+ !any(sapply(skip.par,function(x)all(",if(nmode>1) "unlist(" else NULL, "x",if(nmode>1) ")" else NULL, "==",if(nmode>1) "unlist(" else NULL, "tempclu",if(nmode>1) ")" else NULL, ")))"
+ ),"
+ )
+ ) #checking if the partition should be ignored
+ {
+") else NULL," temp.crit<-crit.fun.tmp(M=useM,clu=tempclu,change=c(i1,i2)",if(nmode==2) ", modechange=imode" else NULL, ",res.old=res.last.iter)
+ if(temp.crit$err<best.crit[[1]]$err) {
+ best.crit<-list(NULL)
+ best.crit[[1]]<-temp.crit
+ imp<-TRUE
+ } else if(temp.crit$err==best.crit[[1]]$err){
+ unique<-TRUE
+ for(i in 1:length(best.crit)){"
+ ,if(switch.names){c("
+ if(rand(table(",if(nmode>1) "unlist(" else NULL, "best.crit[[i]]$clu",if(nmode>1) ")" else NULL, ",",if(nmode>1) "unlist(" else NULL, "temp.crit$clu",if(nmode>1) ")" else NULL, "))==1) unique<-FALSE")
+ }else {c("
+ if(all(",if(nmode>1) "unlist(" else NULL, "best.crit[[i]]$clu",if(nmode>1) ")" else NULL, "==",if(nmode>1) "unlist(" else NULL, "temp.crit$clu",if(nmode>1) ")" else NULL, ")) unique<-FALSE")
+ },"
+ }
+ if(unique) {best.crit[[length(best.crit)+1]]<-temp.crit}
+ }
+", if(check.skip=="all") " }
+" else NULL,if(!is.null(parOK))"}" else NULL," }
+ }") else NULL,"
+ }
+ }
+ }
+ ",if(nmode>1) "}\n\t" else NULL, if(trace.iter) "best.crit.iter[[iter]]<-best.crit" else NULL,"
+ res.last.iter<-best.crit[[1]]
+ clu<-best.crit[[1]]$clu
+", if(check.skip=="iter") c(" if(
+ ifelse(
+ is.null(skip.par),
+ FALSE,",
+ if(switch.names){c("
+ any(sapply(skip.par,",if(nmode>1) "function(x,clu2)rand2(unlist(x),clu2)" else "rand2", ",clu2=",if(nmode>1) "unlist(" else NULL, "clu",if(nmode>1) ")" else NULL, ")==1)")
+ }else{c("
+ any(sapply(skip.par,function(x)all(",if(nmode>1) "unlist(" else NULL, "x",if(nmode>1) ")" else NULL, "==",if(nmode>1) "unlist(" else NULL, "clu",if(nmode>1) ")" else NULL, ")))")
+ },"
+ )
+ ) #checking if the partition should be ignored
+ {
+ imp<-FALSE
+ best.crit[[1]]$err<-NA
+ cat('Optimization ended - partition was in \\'skip.par\\'\\n')
+ }
+") else NULL, if(save.checked.par) " if(imp) checked.par<-c(checked.par,list(clu))
+" else NULL, if(print.iter) c(" cat('End of iteration',iter,'\\n')
+ cat('Current partition: ',",if(nmode>1) "unlist(" else NULL, "clu",if(nmode>1) ")" else NULL, ",'\\n')
+ cat('Current error:',best.crit[[1]]$err,'\\n\\n') #the end of an iteration
+") else NULL," }
+", if(merge.save.skip.par && save.checked.par) " checked.par<-c(skip.par, checked.par)
+" else NULL," cat('Function completed\\n')
+ cat('Final (1st) paritition:',",if(nmode>1) "unlist(" else NULL,"best.crit[[1]]$clu",if(nmode>1) ")" else NULL,",'\\n')
+ cat(length(best.crit),'solution(s) with minimal error =', best.crit[[1]]$err, 'found.','\\n')
+
+ res<-list(M=M,best=best.crit", if(trace.iter) ",iter=best.crit.iter" else NULL,",call=match.call()",if(save.initial.param) ",initial.param = initial.param" else NULL, if(save.checked.par) ", checked.par=checked.par" else NULL,",nIter=iter)
+ class(res)<-'opt.par",if(nmode>1) ".mode" else NULL, "'
+ return(res)
+}\n")
+#cat(fun,sep="",file="tmp.R")
+return(parse(text=paste(fun,sep="",collapse="")))
+}
+
diff --git a/R/genRandomPar.R b/R/genRandomPar.R
new file mode 100644
index 0000000..a3c301f
--- /dev/null
+++ b/R/genRandomPar.R
@@ -0,0 +1,81 @@
+"genRandomPar" <-
+function(
+k,#number of clusters/groups
+n,#the number of units in each mode
+seed=NULL,#the seed for random generation of partitions
+mingr=1, #minimal alowed group size
+maxgr=Inf, #maximal alowed group size
+addParam = list(
+ genPajekPar = TRUE, #Should the partitions be generated as in Pajek (the other options is completly random)
+ probGenMech = NULL) #Here the probabilities for the 4 different mechanizems for specifying the partitions are set. It should be a numeric vector of length 4. If not set this is determined based on the previous parameter.
+){
+ if(is.null(addParam$probGenMech)){
+ if(is.null(addParam$genPajekPar)||addParam$genPajekPar) probGenMech <- c(1/3,1/3,1/3,0) else probGenMech <- c(0,0,0,1)
+ } else probGenMech<-addParam$probGenMech
+ if(!is.null(seed))set.seed(seed)
+ nmode <- length(k)
+ ver<-sample(1:4,size=1,prob=probGenMech)
+ if(nmode==1){
+ find.new.par<-TRUE
+ while(find.new.par){
+ if(ver!=4){
+ temppar<-integer(n)
+
+ if(ver==1){
+ temppar<-1:n%%k+1
+ }
+
+ if(ver==2){
+ temppar[1:k]<-1:k
+ temppar[(k+1):n]<-k
+ }
+
+ if(ver==3){
+ temppar[1:k]<-1:k
+ temppar[(k+1):n]<-1+trunc(k*runif(n-k))
+ }
+
+ for(ii in n:2){
+ jj<-trunc(ii*runif(1))
+ temppar[c(ii,jj)]<-temppar[c(jj,ii)]
+ }
+ }else temppar<-sample(1:k,n,replace=TRUE)
+ temptab<-table(temppar)
+ if(length(temptab)==k&min(temptab)>=mingr&max(temptab)<=maxgr)find.new.par<-FALSE
+ }
+ }else{
+ temppar<-NULL
+ for(imode in 1:nmode){
+ find.new.par<-TRUE
+ while(find.new.par){
+ if(ver!=4){
+ itemppar<-integer(n[imode])
+
+ if(ver==1){
+ itemppar<-1:n[imode]%%k[imode]+1
+ }
+
+ if(ver==2){
+ itemppar[1:k[imode]]<-1:k[imode]
+ itemppar[(k[imode]+1):n[imode]]<-k[imode]
+ }
+
+ if(ver==3){
+ itemppar[1:k[imode]]<-1:k[imode]
+ itemppar[(k[imode]+1):n[imode]]<-1+trunc(k[imode]*runif(n[imode]-k[imode]))
+ }
+
+ for(ii in n[imode]:2){
+ jj<-trunc(ii*runif(1))
+ itemppar[c(ii,jj)]<-itemppar[c(jj,ii)]
+ }
+ }else itemppar<-sample(1:k[imode],n[imode],replace=TRUE)
+ temptab<-table(itemppar)
+ if((length(temptab)==k[imode])&(min(temptab)>=mingr)&(max(temptab)<=maxgr))find.new.par<-FALSE
+ }
+ temppar<-c(temppar,list(itemppar))
+ }
+ }
+ return(temppar)
+}
+
diff --git a/R/genRandomParGroups.R b/R/genRandomParGroups.R
new file mode 100644
index 0000000..870b181
--- /dev/null
+++ b/R/genRandomParGroups.R
@@ -0,0 +1,90 @@
+"genRandomParGroups" <-
+function(
+k,#number of clusters
+n=NULL,#the number of units
+seed=NULL,#the seed for random generation of partitions
+mingr=1, #minimal alowed group size
+maxgr=Inf, #maximal alowed group size
+addParam = list(
+ k = NULL, #number of clusters by groups
+ groups = NULL, #partition of units into groups. The generated partitions are such that units from different groups can not be in the same cluster. Groups are handled similarly as modes in original fucintion
+ genPajekPar = TRUE, #Should the partitions be generated as in Pajek (the other options is completly random)
+ probGenMech = NULL) #Here the probabilities for the 4 different mechanizems for specifying the partitions are set. It should be a numeric vector of length 4. If not set this is determined based on the previous parameter.
+){
+ if(is.null(addParam$probGenMech)){
+ if(is.null(addParam$genPajekPar)||addParam$genPajekPar) probGenMech <- c(1/3,1/3,1/3,0) else probGenMech <- c(0,0,0,1)
+ } else probGenMech<-addParam$probGenMech
+
+ if(k!=sum(addParam$k)) warning("The number of clusters indicated by k and addParam$k is different!!!\n")
+ k<-addParam$k
+
+ if(!is.null(seed))set.seed(seed)
+ nmode <- length(k)
+ groups<-as.integer(factor(addParam$groups))
+ n<-table(groups)
+ ver<-sample(1:4,size=1,prob=probGenMech)
+ if(nmode==1){
+ find.new.par<-TRUE
+ while(find.new.par){
+ if(ver!=4){
+ temppar<-integer(n)
+
+ if(ver==1){
+ temppar<-1:n%%k+1
+ }
+
+ if(ver==2){
+ temppar[1:k]<-1:k
+ temppar[(k+1):n]<-k
+ }
+
+ if(ver==3){
+ temppar[1:k]<-1:k
+ temppar[(k+1):n]<-1+trunc(k*runif(n-k))
+ }
+
+ for(ii in n:2){
+ jj<-trunc(ii*runif(1))
+ temppar[c(ii,jj)]<-temppar[c(jj,ii)]
+ }
+ }else temppar<-sample(1:k,n,replace=TRUE)
+ temptab<-table(temppar)
+ if(length(temptab)==k&min(temptab)>=mingr&max(temptab)<=maxgr)find.new.par<-FALSE
+ }
+ }else{
+ temppar<-integer(sum(n))
+ for(imode in 1:nmode){
+ find.new.par<-TRUE
+ while(find.new.par){
+ if(ver!=4){
+ itemppar<-integer(n[imode])
+
+ if(ver==1){
+ itemppar<-1:n[imode]%%k[imode]+1
+ }
+
+ if(ver==2){
+ itemppar[1:k[imode]]<-1:k[imode]
+ itemppar[(k[imode]+1):n[imode]]<-k[imode]
+ }
+
+ if(ver==3){
+ itemppar[1:k[imode]]<-1:k[imode]
+ itemppar[(k[imode]+1):n[imode]]<-1+trunc(k[imode]*runif(n[imode]-k[imode]))
+ }
+
+ for(ii in n[imode]:2){
+ jj<-trunc(ii*runif(1))
+ itemppar[c(ii,jj)]<-itemppar[c(jj,ii)]
+ }
+ }else itemppar<-sample(1:k[imode],n[imode],replace=TRUE)
+ temptab<-table(itemppar)
+ if(length(temptab)==k[imode]&min(temptab)>=mingr&max(temptab)<=maxgr) find.new.par<-FALSE
+ }
+ itemppar<-itemppar + max(temppar)
+ temppar[groups==imode]<-itemppar
+ }
+ }
+ return(temppar)
+}
+
diff --git a/R/gplot.R b/R/gplot.R
new file mode 100644
index 0000000..7674f8c
--- /dev/null
+++ b/R/gplot.R
@@ -0,0 +1,19 @@
+"gplot1" <-function(M,diag=TRUE,displaylabels=TRUE,boxed.labels=FALSE,loop.cex=4,arrowhead.cex=NULL,arrowheads.fun="sqrt",edge.lwd=1,edge.col="default",rel.thresh=0.05,...){
+ M[M<max(M)*rel.thresh]<-0
+ arrowheads<-t(M)[t(M)!=0]
+ if(is.null(arrowhead.cex)) arrowhead.cex<-do.call(what=arrowheads.fun,list(edge.lwd))
+ arrowheads<-do.call(what=arrowheads.fun,list(arrowheads))*arrowhead.cex
+ if(edge.col=="default") edge.col<-gray(1-M/max(M))
+ library(sna,pos=max(grep(pat="block",search()))+1)
+ gplot(dat=M,diag=diag,displaylabels=displaylabels,boxed.labels=boxed.labels,loop.cex=loop.cex,arrowhead.cex=arrowheads,edge.lwd=edge.lwd,edge.col=edge.col,...)
+}
+
+
+"gplot2" <-
+function(M,uselen=TRUE,usecurve=TRUE,edge.len=0.001,diag=TRUE,displaylabels=TRUE,boxed.labels=FALSE,loop.cex=4,arrowhead.cex=2.5,edge.lwd=1,edge.col="default",rel.thresh=0.05,...){
+ M[M<max(M)*rel.thresh]<-0
+ if(edge.col=="default") edge.col<-gray(1-M/max(M))
+ library(sna,pos=max(grep(pat="block",search()))+1)
+ gplot(dat=M,uselen=uselen,usecurve=usecurve,edge.len=edge.len,diag=diag,displaylabels=displaylabels,boxed.labels=boxed.labels,loop.cex=loop.cex,arrowhead.cex=arrowhead.cex,edge.lwd=edge.lwd,edge.col=edge.col,...)
+}
+
diff --git a/R/ircNorm.R b/R/ircNorm.R
new file mode 100644
index 0000000..25f7579
--- /dev/null
+++ b/R/ircNorm.R
@@ -0,0 +1,22 @@
+ircNorm<-function(M,eps=10^-12,maxiter=1000){
+ diffM<-function(M){
+ max(c(1-apply(M,1,sum)[apply(M,1,sum)>0],1-apply(M,2,sum)[apply(M,2,sum)>0])^2)
+ }
+ side<-1
+ i=0
+ tmpM<-list(M,M)
+ while(diffM(M)>eps){
+ i=i+1
+ M<-sweep(M, side, apply(M, side, sum),FUN="/")
+ M[is.nan(M)]<-0
+ if(max(c(M-tmpM[[side]])^2)<eps) break
+ tmpM[[side]]<-M
+ side<-3-side
+ if(i>=maxiter){
+ warning("Maximum number of itrerations (",maxiter,") reached, convergence not achieved.\n")
+ break
+ }
+ }
+ M<-(tmpM[[1]]+tmpM[[2]])/2
+ return(M)
+}
\ No newline at end of file
diff --git a/R/loadmatrix.R b/R/loadmatrix.R
new file mode 100644
index 0000000..3837d80
--- /dev/null
+++ b/R/loadmatrix.R
@@ -0,0 +1,21 @@
+"loadmatrix" <-
+structure(function(filename){
+ if(is.character(filename)) {file<-file(description=filename,open="r")
+ }else file<-filename
+nn<-read.table(file=file,nrows=1)
+if (length(nn) == 2)
+ { xx<-read.table(file=file,nrows=nn[[2]],fill=TRUE)
+ n<-read.table(file=file,skip=1,nrows=nn[[2]])
+ n<-as.matrix(n)
+ rownames(n)<-xx[[2]]
+ colnames(n)<-xx[[2]] }
+ else
+ {xxrow<-read.table(file=file,nrows=nn[[3]],fill=TRUE)
+ xxcol<-read.table(file=file,nrows=nn[[2]]-nn[[3]],fill=TRUE)
+ n<-read.table(file=file,skip=1,nrows=nn[[3]])
+ n<-as.matrix(n)
+ rownames(n)<-xxrow[[2]]
+ colnames(n)<-xxcol[[2]] }
+ as.matrix(n)
+ }
+, comment = "Load matrix from file that was produced by Pajek")
diff --git a/R/loadnetwork.R b/R/loadnetwork.R
new file mode 100644
index 0000000..3d1f4a5
--- /dev/null
+++ b/R/loadnetwork.R
@@ -0,0 +1,106 @@
+"loadnetwork" <-
+function(filename,useSparseMatrix=NULL,minN=50){
+ n<-read.table(file=filename,nrows=1)
+ if(length(n)==2){
+ n<-as.numeric(n[2])
+ vnames<-read.table(file=filename,skip=1,nrows=n,as.is =TRUE)[,2]
+ if(all(is.na(vnames))){
+ vnames<-NULL
+ } else vnames[is.na(vnames)]<-""
+ rLines<-readLines(con=filename)
+ nl<-length(rLines)
+ ind.stars<-which(regexpr(pattern="*", text=rLines,fixed=TRUE)>0)
+ nstars<-length(ind.stars)
+ stars<-rLines[ind.stars]
+ rm(rLines)
+ if(is.null(useSparseMatrix)){
+ useSparseMatrix<- n>=50
+ }
+
+ if(useSparseMatrix){
+ if(require(Matrix)){
+ M<-Matrix(0,nrow=n,ncol=n,sparse=TRUE)
+ }else{
+ warning("Matrix package is not installed. Ordanary (dense) matrices will be used instead of sparse onse")
+ M<-matrix(0,nrow=n,ncol=n)
+ }
+ }else{
+ M<-matrix(0,nrow=n,ncol=n)
+ }
+
+
+ if(useSparseMatrix){
+ if(require(Matrix)){
+ M<-Matrix(0,nrow=n,ncol=n,sparse=TRUE)
+ }else{
+ M<-matrix(0,nrow=n,ncol=n)
+ warning("Matrix package is not installed. Ordanary (dense) matrices will be used instead of sparse onse")
+ }
+ } else{
+ M<-matrix(0,nrow=n,ncol=n)
+ }
+ for(i in 2:nstars){
+ nrows<-ifelse(i==nstars,-1,ind.stars[i+1]-ind.stars[i]-1)
+ ties<-read.table(file=filename,skip=ind.stars[i],nrows=nrows)
+ ncols<-dim(ties)[2]
+ if(ncols==2){
+ ties<-cbind(ties,1)
+ } else if(ncols>3){
+ ties<-ties[,1:3]
+ }
+ ties<-apply(ties,2,as.numeric)
+ if(stars[i]=="*Arcs"){
+ M[ties[,1:2]]<-ties[,3]
+ } else if(stars[i]=="*Edges"){
+ M[ties[,1:2]]<-ties[,3]
+ M[ties[,2:1]]<-ties[,3]
+ }
+ }
+ dimnames(M)<-list(vnames,vnames)
+ } else{
+ n12<-as.numeric(n[2])
+ n1<-as.numeric(n[3])
+ n2<-n12-n1
+ vnames1<-read.table(file=filename,skip=1,nrows=n12)[,2]
+ vnames<-read.table(file=filename,skip=1,nrows=n12,as.is =TRUE)[,2]
+ if(all(is.na(vnames))){
+ vnames<-NULL
+ } else vnames[is.na(vnames)]<-""
+ rLines<-readLines(con=filename)
+ nl<-length(rLines)
+ ind.stars<-which(regexpr(pattern="*", text=rLines,fixed=TRUE)>0)
+ nstars<-length(ind.stars)
+ stars<-rLines[ind.stars]
+ rm(rLines)
+ if(is.null(useSparseMatrix)){
+ useSparseMatrix<- n12>50
+ }
+ if(useSparseMatrix){
+ if(require(Matrix)){
+ M<-Matrix(0,nrow=n12,ncol=n12,sparse=TRUE)
+ }else{
+ warning("Matrix package is not installed. Ordanary (dense) matrices will be used instead of sparse onse")
+ M<-matrix(0,nrow=n12,ncol=n12)
+ }
+ }else{
+ M<-matrix(0,nrow=n12,ncol=n12)
+ }
+ for(i in 2:nstars){
+ nrows<-ifelse(i==nstars,-1,ind.stars[i+1]-ind.stars[i]-1)
+ ties<-read.table(file=filename,skip=ind.stars[i],nrows=nrows)
+ ncols<-dim(ties)[2]
+ if(ncols==2){
+ ties<-cbind(ties,1)
+ } else if(ncols>3){
+ ties<-ties[,1:3]
+ }
+ ties<-apply(ties,2,as.numeric)
+ M[ties[,1:2]]<-ties[,3]
+ M[ties[,2:1]]<-ties[,3]
+ }
+ dimnames(M)<-list(vnames,vnames)
+ M<-M[1:n1,(n1+1):n12]
+ }
+ return(M)
+}
+
diff --git a/R/loadnetwork2.R b/R/loadnetwork2.R
new file mode 100644
index 0000000..238f361
--- /dev/null
+++ b/R/loadnetwork2.R
@@ -0,0 +1,85 @@
+"loadnetwork2" <-
+function(filename,useSparseMatrix=NULL,minN=50){
+ if(is.character(filename)){
+ file<-file(description=filename,open="r")
+ } else file<-filename
+ n<-read.table(file=file,nrows=1)
+ if(length(n)==2){
+ n<-as.numeric(n[2])
+ vnames<-read.table(file=file,nrows=n,as.is =TRUE)[,2]
+ if(all(is.na(vnames))){
+ vnames<-NULL
+ } else vnames[is.na(vnames)]<-""
+
+ if(is.null(useSparseMatrix)){
+ useSparseMatrix<- n>=50
+ }
+ if(useSparseMatrix){
+ if(require(Matrix)){
+ M<-Matrix(0,nrow=n,ncol=n,sparse=TRUE)
+ }else{
+ M<-matrix(0,nrow=n,ncol=n)
+ warning("Matrix package is not installed. Ordanary (dense) matrices will be used instead of sparse onse")
+ }
+ }else{
+ M<-matrix(0,nrow=n,ncol=n)
+ }
+
+ type=""
+
+ while(TRUE){
+ line<-scan(file = file, nlines =1,what="char",quiet =TRUE)
+ if(length(line)==0||sum(grep(patt="^ *$",x=as.character(line))==1)) break
+ if(substr(line[1],start=1,stop=1)=="*"){
+ type=line[1]
+ next
+ }else line<-as.double(line)
+
+ if(type=="*Arcs"){
+ M[line[1],line[2]]<-line[3]
+ }else if(type=="*Edges") {
+ M[line[1],line[2]]<-line[3]
+ M[line[2],line[1]]<-line[3]
+ }
+ }
+ dimnames(M)<-list(vnames,vnames)
+ } else{
+ n12<-as.numeric(n[2])
+ n1<-as.numeric(n[3])
+ n2<-n12-n1
+ vnames<-read.table(file=file,skip=1,nrows=n12,as.is =TRUE)[,2]
+ if(all(is.na(vnames))){
+ vnames<-NULL
+ } else vnames[is.na(vnames)]<-""
+
+ if(is.null(useSparseMatrix)){
+ useSparseMatrix<- n12>50
+ }
+
+ if(useSparseMatrix){
+ if(require(Matrix)){
+ M<-Matrix(0,nrow=n12,ncol=n12,sparse=TRUE)
+ }else{
+ warning("Matrix package is not installed. Ordanary (dense) matrices will be used instead of sparse onse")
+ M<-matrix(0,nrow=n12,ncol=n12)
+ }
+ } else {
+ M<-matrix(0,nrow=n12,ncol=n12)
+ }
+
+ while(TRUE){
+ line<-scan(file = file, nlines =1,what="char",quiet =TRUE)
+ if(length(line)==0||sum(grep(patt="^ *$",x=as.character(line))==1)) break
+ if(substr(line[1],start=1,stop=1)=="*"){
+ type=line[1]
+ next
+ }else line<-as.double(line)
+
+ M[line[1],line[2]]<-line[3]
+ M[line[2],line[1]]<-line[3]
+ }
+ dimnames(M)<-list(vnames,vnames)
+ M<-M[1:n1,(n1+1):n12]
+ }
+ return(M)
+}
diff --git a/R/loadpajek.R b/R/loadpajek.R
new file mode 100644
index 0000000..1e20b6f
--- /dev/null
+++ b/R/loadpajek.R
@@ -0,0 +1,73 @@
+loadpajek<-function(filename){
+ if(is.character(filename)) {file<-file(description=filename,open="r")
+ }else file<-filename
+ res<-list(Networks=list(),Partitions=list(),Vectors=list(),Permutation=list())
+ nblanklines=0
+ while(TRUE){
+ line<-scan(file = file, nlines =1,what="char",quiet =TRUE)
+ if(length(line)==0) {
+ nblanklines=nblanklines+1
+ if (nblanklines>10) break
+ next
+ }
+ nblanklines=0
+ if(sum(grep(patt="^ *$",x=as.character(line))==1)) next
+ if(line[1]=="*Matrix" || line[1]=="*Network"){
+ objName<-paste(line[-1],collapse=" ")
+ if(line[1]=="*Matrix"){
+ readObj<-loadmatrix(file)
+ }else readObj<-loadnetwork2(file)
+
+ if(objName %in% names(res[["Networks"]])){
+ i<-1
+ while(TRUE){
+ if(paste(objName,"Ver",i) %in% names(res[["Networks"]])) break
+ i<-i+1
+ }
+ objName<-paste(objName,"Ver",i)
+ }
+ res[["Networks"]]<-c(res[["Networks"]],list(readObj))
+ names(res[["Networks"]])[length(res[["Networks"]])]<-objName
+ } else if(line[1]=="*Vector" || line[1]=="*Permutation" || line[1]=="*Partition"){
+ objName<-paste(line[-1],collapse=" ")
+ readObj<-loadvector2(file)
+ if(line[1]=="*Vector"){
+ if(objName %in% names(res[["Vectors"]])){
+ i<-1
+ while(TRUE){
+ if(paste(objName,"Ver",i) %in% names(res[["Vectors"]])) break
+ i<-i+1
+ }
+ objName<-paste(objName,"Ver",i)
+ }
+ res[["Vectors"]]<-c(res[["Vectors"]],list(readObj))
+ names(res[["Vectors"]])[length(res[["Vectors"]])]<-objName
+ } else if(line[1]=="*Permutation"){
+ if(objName %in% names(res[["Permutations"]])){
+ i<-1
+ while(TRUE){
+ if(paste(objName,"Ver",i) %in% names(res[["Permutations"]])) break
+ i<-i+1
+ }
+ objName<-paste(objName,"Ver",i)
+ }
+ res[["Permutations"]]<-c(res[["Permutations"]],list(readObj))
+ names(res[["Permutations"]])[length(res[["Permutations"]])]<-objName
+ } else if(line[1]=="*Partition"){
+ if(objName %in% names(res[["Partitions"]])){
+ i<-1
+ while(TRUE){
+ if(paste(objName,"Ver",i) %in% names(res[["Partitions"]])) break
+ i<-i+1
+ }
+ objName<-paste(objName,"Ver",i)
+ }
+ res[["Partitions"]]<-c(res[["Partitions"]],list(readObj))
+ names(res[["Partitions"]])[length(res[["Partitions"]])]<-objName
+ }
+ }
+
+ }
+ return(res)
+ close(file)
+}
diff --git a/R/loadvector.R b/R/loadvector.R
new file mode 100644
index 0000000..9624af2
--- /dev/null
+++ b/R/loadvector.R
@@ -0,0 +1,8 @@
+"loadvector" <-
+structure(function(filename){
+ vv<-read.table(file=filename,skip=1)
+ if (dim(vv)[2]==1)
+ vv<-vv[[1]]
+ vv
+}
+, comment = "Load vector(s) from file that was produced by Pajek")
diff --git a/R/loadvector2.R b/R/loadvector2.R
new file mode 100644
index 0000000..3582b6d
--- /dev/null
+++ b/R/loadvector2.R
@@ -0,0 +1,11 @@
+"loadvector2" <-
+structure(function(filename){
+ if(is.character(filename)) {file<-file(description=filename,open="r")
+ }else file<-filename
+ nn <-read.table(file=file,nrows=1)
+ vv<-read.table(file=file,nrows=nn[[2]])
+ if (dim(vv)[2]==1)
+ vv<-vv[[1]]
+ vv
+}
+, comment = "Load vector(s) from file that was produced by Pajek")
diff --git a/R/mean.max.col.R b/R/mean.max.col.R
new file mode 100644
index 0000000..81cea25
--- /dev/null
+++ b/R/mean.max.col.R
@@ -0,0 +1,3 @@
+"mean.max.col" <-
+function(x,...)mean(apply(x,2,max,...))
+
diff --git a/R/mean.max.row.R b/R/mean.max.row.R
new file mode 100644
index 0000000..c854a85
--- /dev/null
+++ b/R/mean.max.row.R
@@ -0,0 +1,3 @@
+"mean.max.row" <-
+function(x,...)mean(apply(x,1,max,...))
+
diff --git a/R/meanpos.R b/R/meanpos.R
new file mode 100644
index 0000000..fbebed9
--- /dev/null
+++ b/R/meanpos.R
@@ -0,0 +1,3 @@
+"meanpos" <-
+function(v){mean(v[v>0])}
+
diff --git a/R/nkpar.R b/R/nkpar.R
new file mode 100644
index 0000000..89db10e
--- /dev/null
+++ b/R/nkpar.R
@@ -0,0 +1,6 @@
+"nkpar" <-
+function(n, k) {
+# Author: Chris Andrews <candrews at buffalo.edu>
+ sum((-1)^seq(0,k-1) * choose(k, seq(0,k-1)) * (k-seq(0,k-1))^n) / factorial(k)
+}
+
diff --git a/R/nkpartitions.R b/R/nkpartitions.R
new file mode 100644
index 0000000..af8875c
--- /dev/null
+++ b/R/nkpartitions.R
@@ -0,0 +1,83 @@
+"nkpartitions" <-
+function(n, k, exact=TRUE, print=FALSE) {
+# n objects
+# k subgroups
+# exactly k or at most k?
+# print results as they are found?
+# Author: Chris Andrews <candrews at buffalo.edu>
+ if (n != floor(n) | n<=0) stop("n must be positive integer")
+ if (k != floor(k) | k<=0) stop("k must be positive integer")
+ if (print) {
+ printnkp <- function(a) {
+ for (j in seq(max(a))) cat("{", seq(along=a)[a==j], "} ")
+ cat("\n")
+ }
+ }
+
+# How many?
+ Stirling2nd <- function(n, k) {
+ sum((-1)^seq(0,k-1) * choose(k, seq(0,k-1)) * (k-seq(0,k-1))^n) /
+factorial(k)
+ }
+
+ rows <- Stirling2nd(n,k)
+ if (!exact & k>1) {
+ for (i in seq(k-1,1)) {
+ rows <- rows + Stirling2nd(n,i)
+ }
+ }
+
+ if (print) cat("rows =",rows,"\n")
+
+# Allocate space
+ theparts <- matrix(NA, nrow=rows, ncol=n)
+
+# begin counting
+ howmany <- 0
+
+# all in one group
+ a <- rep(1,n)
+
+# does this count?
+ if (!exact | (k==1)) {
+# increase count, store, and print
+ howmany <- howmany + 1
+ theparts[howmany,] <- a
+ if (print) printnkp(a)
+ }
+
+# search for others
+ repeat {
+
+# start at high end
+ last <- n
+ repeat {
+
+# increment it if possible
+ if ((a[last] <= max(a[1:(last-1)])) & (a[last] < k)) {
+ a[last] <- a[last]+1
+
+# does this count?
+ if (!exact | max(a)==k) {
+# increase count, store, and print
+ howmany <- howmany + 1
+ theparts[howmany,] <- a
+ if (print) printnkp(a)
+ }
+# start again at high end.
+ break
+ }
+
+# otherwise set to 1 and move to a different object
+ a[last] <- 1
+ if (last>2) {
+ last <- last-1
+ next
+ }
+
+# report the partitions
+ return(theparts)
+ }
+ }
+}
+
diff --git a/R/one2two.R b/R/one2two.R
new file mode 100644
index 0000000..121b126
--- /dev/null
+++ b/R/one2two.R
@@ -0,0 +1,11 @@
+"one2two" <-
+function(M,clu=NULL){
+ if(!is.null(clu)){
+ if(mode(clu)=="list"){
+ n<-sapply(clu,FUN=length)
+ newM<-M[1:n[1],(n[1]+1):sum(n[1:2])]
+ } else stop("For now clu must be supplied in form of a list (one component for each mode)")
+ } else stop("For now clu must be supplied in form of a list (one component for each mode)")
+ return(list(M=newM,clu=clu))
+}
+
diff --git a/R/opt.par.R b/R/opt.par.R
new file mode 100644
index 0000000..499187e
--- /dev/null
+++ b/R/opt.par.R
@@ -0,0 +1,56 @@
+"opt.par" <-
+function(
+ #function for optimizig partition in blockmodeling
+ M, #matrix
+ clu, #partition or a list of paritions for each mode
+# e1, #weight of the error of binearized matrix
+# e2, #weight of the error of valued conenctions
+ #m=NULL, #suficient value individual cells
+# s="default", #suficient value for colum and row statistics
+# FUN, #function to calculate row and colum statistics
+# blocks#=c("null","com","reg"), #permissible block types and their ordering
+# BLOCKS=NULL, #array of permissible block types and their ordering for all blocks
+# mindim = 2, #minimal dimension for regulal, dominant and functional blocks
+# save.err.v=FALSE, #save a vector of errors of all block types for all blocks
+ approach,
+ ..., #other arguments to called functions - to 'crit.fun' or 'opt.par.tmp'
+ maxiter=50, #maximum number of iterations
+ trace.iter=FALSE, #save a result of each iteration or only the best (minimal error)
+ switch.names=NULL, #should partitions that only differ in group names be considert equal (is c(1,1,2)==c(2,2,1))
+ save.initial.param=TRUE, #should the initial parameters be saved
+# force.fun=NULL, #select the function used to evaluate partition
+ skip.par=NULL, #the partions that are not allowed or were already checked and should be skiped
+ save.checked.par=!is.null(skip.par), #should the checked partitions be saved
+ merge.save.skip.par=all(!is.null(skip.par),save.checked.par), #should the checked partitions be merged with skiped ones
+ check.skip="never" #when should the check be preformed:
+ # "all" - before every call to 'crit.fun'
+ # "iter" - at the end of eack iteratiton
+ # "opt.par" - before every call to 'opt.par', implemented in opt.these.par and opt.random.par
+ # "never" - never
+){
+ if(is.list(clu)){
+ k<-sapply(clu,function(x)length(unique(x)))
+ } else k<-length(unique(clu))
+
+ dots<-list(...)
+ if(is.null(switch.names)){
+ switch.names<-is.null(dots$BLOCKS)
+ }
+
+
+ nmode<-length(k)
+
+ if(nmode==1) clu<-as.integer(factor(clu))
+ if(nmode==2) clu<-lapply(clu,function(x)as.integer(factor(x)))
+ if(nmode>2) {
+ clu<-lapply(clu,function(x)as.integer(factor(x)))
+ for(i in 2:length(clu)){
+ clu[[i]]<-clu[[i]] + max(clu[[i-1]])
+ }
+ }
+
+ optfun<-gen.opt.par(M=M,k=k,maxiter=maxiter,approach=approach,trace.iter=trace.iter,save.initial.param = save.initial.param,skip.par=skip.par,save.checked.par=save.checked.par,merge.save.skip.par=merge.save.skip.par,check.skip=check.skip,switch.names=switch.names,...)
+ eval(optfun)
+ return(opt.par.tmp(M=M,clu=clu,k=k,approach=approach,...))
+}
+
diff --git a/R/opt.random.par.R b/R/opt.random.par.R
new file mode 100644
index 0000000..e00771e
--- /dev/null
+++ b/R/opt.random.par.R
@@ -0,0 +1,161 @@
+"opt.random.par" <-
+function(
+M,#matrix (network)
+k,#number of clusters/groups
+n=NULL,#the number of units in each mode (only necessary if mode is larger than 2)
+rep,#number of repetitions/different starting partitions to check
+approach,
+...,
+return.all=FALSE,#if 'FALSE', solution for only the best (one or more) partition/s is/are returned
+return.err=TRUE,#if 'FALSE', only the resoults of crit.fun are returned (a list of all (best) soulutions including errors), else the resoult is list
+maxiter=50,#maximum number of iterations
+#m=NULL,#suficient value individual cells
+#cut=min(M[M>0]), #
+#BLOCKS=NULL,#array of permissible block types and their ordering for all blocks
+trace.iter=FALSE,#save a result of each iteration or only the best (minimal error)
+switch.names=NULL,#should partitions that only differ in group names be considert equal (is c(1,1,2)==c(2,2,1))
+save.initial.param=TRUE,#should the initial parameters be saved
+skip.par=NULL,#the partions that are not allowed or were already checked and should be skiped
+save.checked.par=TRUE,#should the checked partitions be saved
+merge.save.skip.par=any(!is.null(skip.par),save.checked.par), #should the checked partitions be merged with skiped ones
+skip.allready.checked.par=TRUE,#if 'TRUE',the partitions that were already checked when runing 'opt.par' form different statrting points will be skiped
+check.skip="iter",#when should the check be preformed:
+# "all" - before every call to 'crit.fun'
+# "iter" - at the end of eack iteratiton
+# "opt.par" - before every call to 'opt.par', implemented in opt.these.par and opt.random.par
+# "never" - never
+#use.for=TRUE, #should fortran rutines be used when possible
+print.iter=FALSE, #should the progress of each iteration be printed
+max.iden=10, #the maximum number of results that should be saved (in case there are more than max.iden results with minimal error, only the first max.iden will be saved)
+seed=NULL,#the seed for random generation of partitions
+parGenFun = genRandomPar, #The function that will generate random partitions. It should accept argumetns: k (number of partitions by modes, n (number of units by modes), seed (seed value for random generation of partition), addParam (a list of additional parametres)
+mingr=1, #minimal alowed group size
+maxgr=Inf, #maximal alowed group size
+addParam=list( #list of additional parameters for gerenrating partitions. Here they are specified for dthe default function "genRandomPar"
+genPajekPar = TRUE, #Should the partitions be generated as in Pajek (the other options is completly random)
+probGenMech = NULL), #Here the probabilities for different mechanizems for specifying the partitions are set. If not set this is determined based on the previous parameter.
+maxTriesToFindNewPar=rep*10 #The maximum number of partition try when trying to find a new partition to optimize that was not yet checked before
+){
+
+ dots<-list(...)
+ if(is.null(switch.names)){
+ switch.names<-is.null(dots$BLOCKS)
+ }
+
+
+ if(save.initial.param)initial.param<-c(tryCatch(lapply(as.list(sys.frame(sys.nframe())),eval),error=function(...)return("error")),dots=list(...))#saves the inital parameters
+ optfun<-gen.opt.par(M=M,k=k,maxiter=maxiter, approach=approach,switch.names=switch.names,trace.iter=trace.iter,save.initial.param = save.initial.param,skip.par=skip.par,save.checked.par=save.checked.par,merge.save.skip.par=merge.save.skip.par,check.skip=check.skip,print.iter=print.iter,mingr=mingr,maxgr=maxgr,...)
+ eval(optfun)
+
+ nmode<-length(k)
+
+ res<-list(NULL)
+ err<-NULL
+ nIter<-NULL
+
+ if(nmode==1){
+ n<-dim(M)[1]
+ } else if(nmode==2){
+ n<-dim(M)
+ }
+
+ if(!is.null(seed))set.seed(seed)
+
+ on.exit({
+ res1 <- res[which(err==min(err, na.rm = TRUE))]
+ best<-NULL
+ best.clu<-NULL
+ for(i in 1:length(res1)){
+ for(j in 1:length(res1[[i]]$best)){
+ if(
+ ifelse(is.null(best.clu),
+ TRUE,
+ if(nmode==1) ifelse(switch.names,
+ !any(sapply(best.clu,rand2,clu2=res1[[i]]$best[[j]]$clu)==1),
+ !any(sapply(best.clu,function(x)all(x==res1[[i]]$best[[j]]$clu)))
+ ) else ifelse(switch.names,
+ !any(sapply(best.clu,function(x,clu2)rand2(unlist(x),clu2),clu2=unlist(res1[[i]]$best[[j]]$clu))==1),
+ !any(sapply(best.clu,function(x)all(unlist(x)==unlist(res1[[i]]$best[[j]]$clu))))
+ )
+ )
+ ){
+ best<-c(best,res1[[i]]$best[j])
+ best.clu<-c(best.clu,list(res1[[i]]$best[[j]]$clu))
+ }
+
+ if(length(best)>=max.iden) {
+ warning("Only the first ",max.iden," solutions out of ",length(na.omit(err))," solutions with minimal error will be saved.\n")
+ break
+ }
+
+ }
+ }
+
+ names(best)<-paste("best",1:length(best),sep="")
+
+ if(any(na.omit(err)==Inf) || ss(na.omit(err))!=0 || length(na.omit(err))==1){
+ cat("\n\nOptimization of all partitions completed\n")
+ cat(length(best),"solution(s) with minimal error =", min(err,na.rm=TRUE), "found.","\n")
+ }else {
+ cat("\n\nOptimization of all partitions completed\n")
+ cat("All",length(na.omit(err)),"solutions have err",err[1],"\n")
+ }
+
+ call<-list(call=match.call())
+ best<-list(best=best)
+ checked.par<-list(checked.par=skip.par)
+ if(return.all) res<-list(res=res) else res<-NULL
+ if(return.err) err<-list(err=err) else err<-NULL
+ if(!exists("initial.param")){
+ initial.param<-NULL
+ } else initial.param=list(initial.param)
+
+ res<-c(list(M=M),res,best,err,list(nIter=nIter),checked.par,call,initial.param=initial.param)
+ class(res)<-"opt.more.par"
+ return(res)
+ })
+
+
+ for(i in 1:rep){
+ cat("\n\nStarting optimization of the partiton",i,"of",rep,"partitions.\n")
+ find.unique.par<-TRUE
+ ununiqueParTested=0
+ while(find.unique.par){
+ temppar<-parGenFun(n=n,k=k,seed=seed,mingr=mingr,maxgr=maxgr,addParam=addParam)
+
+ find.unique.par<-
+ ifelse(is.null(skip.par),
+ FALSE,
+ if(nmode==1) ifelse(switch.names,
+ any(sapply(skip.par,rand2,clu2=temppar)==1),
+ any(sapply(skip.par,function(x)all(x==temppar)))
+ ) else ifelse(switch.names,
+ any(sapply(skip.par,function(x,clu2)rand2(unlist(x),clu2),clu2=unlist(temppar))==1),
+ any(sapply(skip.par,function(x)all(unlist(x)==unlist(temppar))))
+ )
+ )
+ ununiqueParTested=ununiqueParTested+1
+ endFun<-ununiqueParTested>=maxTriesToFindNewPar
+ if(endFun) {
+ break
+ } else if(ununiqueParTested%%10==0) cat(ununiqueParTested,"partitions tested for unique partition\n")
+ }
+
+ if(endFun) break
+
+ res[[i]]<-opt.par.tmp(
+ M=M,
+ clu=temppar,
+ k=k,
+ approach=approach,
+ skip.par=skip.par,
+ ...
+ )
+
+ err[i]<-res[[i]]$best[[1]]$err
+ nIter[i]<-res[[i]]$nIter
+ if(skip.allready.checked.par && save.checked.par)skip.par<-res[[i]]$checked.par
+ }
+
+}
+
diff --git a/R/opt.these.par.R b/R/opt.these.par.R
new file mode 100644
index 0000000..eb4f862
--- /dev/null
+++ b/R/opt.these.par.R
@@ -0,0 +1,131 @@
+"opt.these.par" <-
+function(
+ M, #matrix (network)
+ partitions, #a list of partitions to check
+ approach,
+ ...,
+ return.all=FALSE, #if 'FALSE', solution for only the best (one or more) partition/s is/are returned
+ return.err=TRUE, #Should a vector of errors be returned
+ skip.allready.checked.par=TRUE, #if 'TRUE',the partitions that were already checked when runing 'opt.par' form different statrting points will be skiped
+ maxiter=50, #maximum number of iterations
+ #m=NULL, #suficient value individual cells
+ #cut=min(M[M>0]), #
+ #BLOCKS=NULL, #array of permissible block types and their ordering for all blocks
+ trace.iter=FALSE, #save a result of each iteration or only the best (minimal error) (an argument of "gen.opt.par")
+ switch.names=NULL, #should partitions that only differ in group names be considert equal (is c(1,1,2)==c(2,2,1))
+ save.initial.param=TRUE, #should the initial parameters be saved
+ skip.par=NULL, #the partions that are not allowed or were already checked and should be skiped
+ save.checked.par=!is.null(skip.par), #should the checked partitions be saved
+ merge.save.skip.par=all(!is.null(skip.par),save.checked.par), #should the checked partitions be merged with skiped ones
+ check.skip="never", #when should the check be preformed:
+ # "all" - before every call to 'crit.fun'
+ # "iter" - at the end of eack iteratiton
+ # "opt.par" - before every call to 'opt.par', implemented in opt.these.par and opt.random.par
+ # "never" - never
+ print.iter=FALSE
+
+){
+ if(save.initial.param)initial.param<-c(tryCatch(lapply(as.list(sys.frame(sys.nframe())),eval),error=function(...)return("error")),dots=list(...))#saves the inital parameters
+
+ res<-list(NULL)
+ err<-NULL
+ nIter<-NULL
+
+ dots<-list(...)
+ if(is.null(switch.names)){
+ switch.names<-is.null(dots$BLOCKS)
+ }
+
+ clu<-partitions[[1]]
+ if(is.list(clu)){
+ k<-sapply(clu,function(x)length(unique(x)))
+ } else k<-length(unique(clu))
+
+ nmode<-length(k)
+
+ optfun<-gen.opt.par(M=M,k=k,maxiter=maxiter,approach=approach,switch.names=switch.names,trace.iter=trace.iter,save.initial.param = save.initial.param,skip.par=skip.par,save.checked.par=save.checked.par,merge.save.skip.par=merge.save.skip.par,check.skip=check.skip,print.iter=print.iter,...)
+
+ on.exit({
+ res1 <- res[which(err==min(err, na.rm = TRUE))]
+
+ best<-NULL
+ best.clu<-NULL
+ for(i in 1:length(res1)){
+ for(j in 1:length(res1[[i]]$best)){
+ if(
+ ifelse(is.null(best.clu),
+ TRUE,
+ if(nmode==1) ifelse(switch.names,
+ !any(sapply(best.clu,rand2,clu2=res1[[i]]$best[[j]]$clu)==1),
+ !any(sapply(best.clu,function(x)all(x==res1[[i]]$best[[j]]$clu)))
+ ) else ifelse(switch.names,
+ !any(sapply(best.clu,function(x,clu2)rand2(unlist(x),clu2),clu2=unlist(res1[[i]]$best[[j]]$clu))==1),
+ !any(sapply(best.clu,function(x)all(unlist(x)==unlist(res1[[i]]$best[[j]]$clu))))
+ )
+ )
+ ){
+ best<-c(best,res1[[i]]$best[j])
+ best.clu<-c(best.clu,list(res1[[i]]$best[[j]]$clu))
+ }
+ }
+ }
+
+ names(best)<-paste("best",1:length(best),sep="")
+
+ cat("\n\nOptimization of all partitions completed\n")
+ cat(length(best),"solution(s) with minimal error =", min(err,na.rm=TRUE), "found.","\n")
+
+
+ checked.par<-list(checked.par=skip.par)
+ call<-list(call=match.call())
+ best<-list(best=best)
+ if(return.all) res<-list(res=res) else res<-NULL
+ if(return.err) err<-list(err=err) else err<-NULL
+ if(!exists("initial.param")){
+ initial.param<-NULL
+ } else initial.param=list(initial.param)
+
+ res<-c(list(M=M),res,best,err,list(nIter=nIter),checked.par,call,initial.param=initial.param)
+ class(res)<-"opt.more.par"
+ return(res)
+ })
+
+
+ eval(optfun)
+ npar<-length(partitions)
+ for(i in 1:npar){
+ cat("\n\nStarting optimization of the partiton",i,"of",npar,"partitions.\n")
+ if(
+ ifelse(check.skip=="never",
+ TRUE,
+ ifelse(is.null(skip.par),
+ TRUE,
+ if(nmode==1) ifelse(switch.names,
+ !any(sapply(skip.par,rand2,clu2=res1[[i]]$best[[j]]$clu)==1),
+ !any(sapply(skip.par,function(x)all(x==res1[[i]]$best[[j]]$clu)))
+ ) else ifelse(switch.names,
+ !any(sapply(skip.par,function(x,clu2)rand2(unlist(x),clu2),clu2=unlist(res1[[i]]$best[[j]]$clu))==1),
+ !any(sapply(skip.par,function(x)all(unlist(x)==unlist(res1[[i]]$best[[j]]$clu))))
+ )
+ )
+ )
+ ) #checking if the partition should be ignored
+ {
+
+ res[[i]]<-opt.par.tmp(
+ M=M,
+ clu=partitions[[i]],
+ k=k,
+ approach=approach,
+ m=m,
+ skip.par=skip.par,
+ ...
+ )
+
+ err[i]<-res[[i]]$best[[1]]$err
+ nIter[i]<-res[[i]]$nIter
+ if(skip.allready.checked.par) skip.par<-c(skip.par,res[[i]]$checked.par)
+ } else cat("Optimization of the partition skipped\n")
+ }
+}
+
diff --git a/R/parOKgroups.R b/R/parOKgroups.R
new file mode 100644
index 0000000..95551c3
--- /dev/null
+++ b/R/parOKgroups.R
@@ -0,0 +1,7 @@
+"parOKgroups" <-
+function(clu,
+parOKaddParam #list of additional parameters, at lest k and groups
+){
+ isTRUE(all(cut(clu,c(0,cumsum(parOKaddParam$k)),labels =FALSE)==parOKaddParam$groups))
+
+}
diff --git a/R/plot.check.these.par.R b/R/plot.check.these.par.R
new file mode 100644
index 0000000..9fe5320
--- /dev/null
+++ b/R/plot.check.these.par.R
@@ -0,0 +1,15 @@
+"plot.check.these.par" <-
+function(
+ x, #an "check.these.par" class object
+ main=NULL,
+ which=1, #which (if there are more than one) of optimal solutions to plot
+ ... #aditional parameters to "plot.mat"
+){
+ if(is.null(main)) main <- deparse(substitute(x))
+ if(which>length(x$best)){
+ warning("The selected (",which,") best solution does not exist!\nOnly ", length(x$best)," best solution(s) exist(s).\nThe first best solution will be ploted.\n")
+ which<-1
+ }
+ plot.mat(x$M,clu=x$best[[which]]$clu,IM=x$best[[which]]$IM,main=main,...)
+}
+
diff --git a/R/plot.crit.fun.R b/R/plot.crit.fun.R
new file mode 100644
index 0000000..8f335dc
--- /dev/null
+++ b/R/plot.crit.fun.R
@@ -0,0 +1,10 @@
+"plot.crit.fun" <-
+function(
+ x,#an "opt.par" class object
+ main=NULL,
+ ... #aditional parameters to "plot.mat"
+){
+ if(is.null(main)) main <- deparse(substitute(x))
+ plot.mat(x$M,clu=x$clu,IM=x$IM,main=main,...)
+}
+
diff --git a/R/plot.mat.R b/R/plot.mat.R
new file mode 100644
index 0000000..cc22dd0
--- /dev/null
+++ b/R/plot.mat.R
@@ -0,0 +1,239 @@
+"plot.mat" <-
+function(
+ x=M, #x should be a matrix or similar object
+ M=x, #M should be a matrix or similar object - both (x and M) are here to make the code compatible with generic plot and with older versions of plot.mat and possbily some other functions in the package
+ clu=NULL, #partition
+ ylab="",
+ xlab="",
+ main=NULL,
+ print.val=!length(table(M))<=2, #should the values be printed inside the cells
+ print.0=FALSE, #should the values equal to 0 be printed inside the cells, only used if 'print.val == TRUE'
+ plot.legend=!print.val&&!length(table(M))<=2, #should the legend for the colors be ploted
+ print.legend.val="out", #where should the values for the legend be printed: 'out' - outside the cells (bellow), 'in' - inside the cells, 'both' - inside and outside the cells
+ print.digits.legend=2, #the number of digits that should appear in the legend
+ print.digits.cells=2, #the number of digits that should appear in the cells (of the matrix and/or legend)
+ print.cells.mf=NULL, #if not null, the above argument is igonred, the cell values are printed as the cell are multiplied by this factor and rounded
+ outer.title=!plot.legend, #should the title be printed on the 'inner' or 'outer' plot, default is 'inner' if legend is ploted and 'outer' otherwise
+ title.line= ifelse(outer.title,-1.5,7), #the line (from the top) where the title should be printed
+ mar= c(0.5, 7, 8.5, 0)+0.1, #A numerical vector of the form 'c(bottom, left, top, right)' which gives the lines of margin to be specified on the four sides of the plot. The default is 'c(5, 4, 4, 2) + 0.1'.
+ cex.val="default", #size of the values printed
+ val.y.coor.cor = 0, #correction for centering the values in the sqares in y direction
+ val.x.coor.cor = 0, #correction for centering the values in the sqares in x direction
+ cex.legend=1, #size of the text in the legend,
+ legend.title="Legend", #the title of the legend
+ cex.axes="default", #size of the characters in axes, 'default' makes the cex so small that all categories can be printed
+ print.axes.val=NULL, #should the axes values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL'
+ print.x.axis.val=!is.null(colnames(M)), #should the x axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL'
+ print.y.axis.val=!is.null(rownames(M)), #should the y axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL'
+ x.axis.val.pos = 1.1, #y coordiante of the x axis values
+ y.axis.val.pos = -0.1, #x coordiante of the y axis values
+ cex.main=par()$cex.main,
+ cex.lab=par()$cex.lab,
+ yaxis.line=-1.5, #the position of the y axis (the argument 'line')
+ xaxis.line=-1, #the position of the x axis (the argument 'line')
+ legend.left=0.4,#how much left should the legend be from the matrix
+ legend.up=0.03, #how much left should the legend be from the matrix
+ legend.size=1/min(dim(M)), #relative legend size
+ legend.text.hor.pos=0.5, #horizontal position of the legend text (bottom) - 0 = bottom, 0.5 = middle,...
+ par.line.width = 3, #the width of the line that seperates the partitions
+ par.line.col = "blue", #the color of the line that seperates the partitions
+ IM.dens= NULL,
+ IM= NULL, #Image used for ploting (shaded lines)
+ wnet=1, #which net (if more) should be ploted - used if M is an array
+ wIM=NULL, #which IM (if more) should be used for ploting (defualt = wnet) - used if IM is an array
+ use.IM=length(dim(IM))==length(dim(M))|!is.null(wIM), #should IM be used for ploting?
+ dens.leg=c(null=100),
+ blackdens=70,
+ plotLines = TRUE, #Should the lines in the matrix be printed (best set to FALSE for larger networks)
+ ... #aditional arguments to plot.default
+){
+ old.mar<-par("mar")
+ if(length(dim(IM))>2&use.IM){
+ if(is.null(wIM))wIM<-wnet
+ IM<-IM[wIM,,]
+ }
+
+ if(class(M)!="matrix"&&class(M)!="mat"){
+ pack<-attr(class(M),"package")
+ if(!(is.null(pack))&&pack=="Matrix"){
+ if(require(Matrix)){
+ M<-as.matrix(M)
+ } else stop("The supplied object needs Matrix packege, but the package is not available (install it!!!).")
+ } else stop("Cannot convert object of class ",class(M)," to class 'matrix'.")
+ }
+
+ if(length(dim(M))>2)M<-M[wnet,,]
+ dm<-dim(M)
+
+ if(is.null(main)){
+ objName<-deparse(substitute(M))
+ if(objName=="x")objName<-deparse(substitute(x))
+ main <- paste("Matrix",objName)
+ }
+ #if(length(main)>26)
+
+ if(is.logical(print.axes.val)){
+ print.x.axis.val<-print.y.axis.val<-print.axes.val
+ }
+
+
+ #defining text on the axes if row or colnames do not exist
+ if(is.null(rownames(M))){
+ rownames(M)<-1:dm[1]
+ }
+ if(is.null(colnames(M))){
+ colnames(M)<-1:dm[2]
+ }
+
+ if(!is.null(clu)){ #is any clustering provided, ordering of the matrix if 'TRUE'
+ if(!is.list(clu)){
+ tclu<-table(clu)
+ or.c<-or.r<-order(clu)
+ clu<-list(clu,clu)
+ lines.col<-cumsum(tclu)[-length(tclu)]*1/dm[2]
+ lines.row<-1-lines.col
+ }else if(is.list(clu)&&length(clu)==2){
+ if(is.null(clu[[1]])) clu[[1]]<-rep(1,times=dm[1])
+ if(is.null(clu[[2]])) clu[[2]]<-rep(1,times=dm[2])
+ tclu.r<-table(clu[[1]])
+ tclu.c<-table(clu[[2]])
+ or.r<-order(clu[[1]])
+ or.c<-order(clu[[2]])
+ lines.col<-cumsum(tclu.c)[-length(tclu.c)]*1/dm[2]
+ lines.row<- 1-cumsum(tclu.r)[-length(tclu.r)]*1/dm[1]
+ } else stop("Networks with more that 2 modes (ways) must convert to 1-mode networks before it is sent to this function.")
+ M<-M[or.r,or.c]
+ clu<-lapply(clu,function(x)as.numeric(factor(x)))
+ }
+
+
+
+ if(is.null(IM.dens)){
+ if(!is.null(IM)&use.IM){
+ IM.dens<-matrix(-1,ncol=dim(IM)[2],nrow=dim(IM)[1])
+ for(i in names(dens.leg)){
+ IM.dens[IM==i]<- dens.leg[i]
+ }
+ }
+ }
+
+
+ if(!is.null(IM.dens)){
+ dens<-matrix(-1,nrow=dm[1], ncol=dm[2])
+ for(i in unique(clu[[1]])){
+ for(j in unique(clu[[2]])){
+ dens[clu[[1]]==i,clu[[2]]==j]<-IM.dens[i,j]
+ }
+ }
+ dens<-dens[or.r,or.c]
+ }
+
+
+ if(cex.axes=="default"){ #defining the size of text on the axes
+ cex.x.axis<-min(15/dm[2],1)
+ cex.y.axis<-min(15/dm[1],1)
+ }else{
+ cex.x.axis<-cex.axes
+ cex.y.axis<-cex.axes
+ }
+
+ #defining text on the axes
+ yaxe<-rownames(M)
+ xaxe<-colnames(M)
+
+
+ ytop <- rep(x=(dm[1]:1)/dm[1],times=dm[2]) #definin the positions of rectangules
+ ybottom<- ytop - 1/dm[1]
+ xright <- rep(x=(1:dm[2])/dm[2],each=dm[1])
+ xleft <- xright - 1/dm[2]
+ aM<-abs(M)
+ max.aM<-max(aM)
+ if(max.aM!=0){
+ col<-grey(1-as.vector(aM)/max.aM) #definin the color of rectangules
+ }else col<-matrix(grey(1),nrow=dm[1],ncol=dm[2])
+ asp<-dm[1]/dm[2] #making sure that the cells are squares
+ col[M<0]<-paste("#FF",substr(col[M<0],start=4,stop=7),sep="")
+
+ par(mar=mar, xpd=NA) #ploting
+ plot.default(c(0,1),c(0,1),type="n",axes=FALSE,ann=F,xaxs="i",asp=asp,...)
+ if(is.null(IM.dens)||all(IM.dens==-1)){
+ rect(xleft=xleft, ybottom=ybottom, xright=xright, ytop=ytop, col=col,cex.lab=cex.lab,border=if(plotLines)"black" else NA)
+ }else{
+ rect(xleft=xleft, ybottom=ybottom, xright=xright, ytop=ytop, col=col,cex.lab=cex.lab,density=dens,border=if(plotLines)"black" else NA)
+ }
+ if(!is.null(clu)){ #ploting the lines between clusters
+ if(length(lines.row)) segments(x0=-0.1,x1=1,y0=lines.row,y1=lines.row,col=par.line.col,lwd=par.line.width)
+ if(length(lines.col)) segments(y0=0,y1=1.1,x0=lines.col,x1=lines.col,col=par.line.col,lwd=par.line.width )
+ }
+ if(print.y.axis.val) text(x=y.axis.val.pos, y = (dm[1]:1)/dm[1]-1/dm[1]/2 +val.y.coor.cor,labels = yaxe,cex=cex.y.axis,adj=1)
+ if(print.x.axis.val) text(y=x.axis.val.pos, x = (1:dm[2])/dm[2]-1/dm[2]/2 +val.x.coor.cor, srt=90, labels = xaxe, cex=cex.x.axis,adj=0)
+ title(outer=outer.title,ylab=ylab,xlab=xlab,main=main, line=title.line,cex.main=cex.main)
+ if(print.val){ #ploting the values in the cells if selected
+ norm.val<-as.vector(M)/max(abs(M))
+ col.text<-1-round(abs(norm.val))
+
+ if(!print.0) col.text[as.vector(M)==0]<-0
+ if(length(table(col.text))==2) {
+ col.labels<-c("white","black")
+ } else col.labels<-c("white")
+ col.text<-as.character(factor(col.text,labels=col.labels))
+ if(!is.null(IM.dens)&&!all(IM.dens==-1)) col.text[col.text=="white"&dens>0&dens<blackdens]<-"black"
+ col.text[col.text=="black"&norm.val<0]<-"red"
+ if(!print.0) col.text[as.vector(M)==0]<-"transparent"
+
+ maxM<-formatC(max(M),format="e")
+ if(is.null(print.cells.mf)){
+ if(all(trunc(M)==M)& max(M)<10^print.digits.cells){
+ multi<-1
+ }else{
+ multi<-floor(log10(max(M)))
+ multi<-(multi-(print.digits.cells - 1))*(-1)
+ multi<-10^multi
+ }
+ }else multi <- print.cells.mf
+ M.plot<-round(M*multi)
+
+ text(x=(xleft+xright)/2+val.x.coor.cor,y=(ytop+ybottom)/2+val.y.coor.cor, labels=as.vector(M.plot),col=col.text,cex=ifelse(cex.val=="default",min(10/max(dm),1),cex.val))
+ if(multi!=1) mtext(text=paste("* all values in cells were multiplied by ",multi,sep=""),side=1, line=-0.7,cex=0.70)
+ }
+
+ if(plot.legend){ #ploting the legend if selected
+ if(asp>=1){
+ xright.legend<- -legend.left
+ xleft.legend <- xright.legend - 1*legend.size*asp
+ ybottom.legend <- 1+(4:0)*legend.size+ legend.up
+ ytop.legend <- ybottom.legend + 1*legend.size
+ }else{
+ xright.legend<- -legend.left
+ xleft.legend <- xright.legend - 1*legend.size
+ ybottom.legend <- 1+(4:0)*legend.size*asp+ legend.up
+ ytop.legend <- ybottom.legend + 1*legend.size*asp
+ }
+ col.legend<-gray(4:0/4)
+ rect(xleft=xleft.legend, ybottom=ybottom.legend, xright=xright.legend, ytop=ytop.legend, col=col.legend)
+ if(print.legend.val=="out"|print.legend.val=="both") text(x=xright.legend + 1/20,y= (ytop.legend+ybottom.legend)/2, labels=formatC(0:4/4*max(M), digits = print.digits.legend,format="g"),adj=0,cex=cex.legend)
+ text(x=xleft.legend,y=ytop.legend[1] + legend.size/asp/2+0.02, labels=legend.title,font=2,cex=cex.legend,adj=0)
+
+ if(print.legend.val=="in"|print.legend.val=="both"){
+ col.text.legend<-round(4:0/4)
+ if(!print.0) col.text.legend[1]<-0
+ col.text.legend<-as.character(factor(col.text.legend,labels=c("white","black")))
+ if(!print.val){
+ if(is.null(print.cells.mf)){
+ if(all(trunc(M)==M)& max(M)<10^print.digits.cells){
+ multi<-1
+ }else{
+ multi<-floor(log10(max(M)))
+ multi<-(multi-(print.digits.cells - 1))*(-1)
+ multi<-10^multi
+ }
+ }else multi <- print.cells.mf
+ maxM<-round(max(M)*multi)
+ } else maxM<-max(M.plot)
+ text(x=(xleft.legend+xright.legend)/2,y=(ytop.legend+ybottom.legend)/2, labels=round(0:4/4*maxM),col=col.text.legend,cex=cex.legend)
+ }
+ }
+
+ par(mar=old.mar)
+}
+
diff --git a/R/plot.mat.nm.R b/R/plot.mat.nm.R
new file mode 100644
index 0000000..6bdcf85
--- /dev/null
+++ b/R/plot.mat.nm.R
@@ -0,0 +1,20 @@
+"plot.mat.nm" <-
+function(x=M,M=x,...,main.title=NULL,title.row="Row normalized",title.col="Column normalized",main.title.line=-2,par.set=list(mfrow=c(1,2))){
+ if(is.null(main.title)){
+ objName<-deparse(substitute(M))
+ if(objName=="x")objName<-deparse(substitute(x))
+ main.title <- paste("Matrix",objName)
+ }
+ if(!is.null(par)){
+ par.def<-par(no.readonly = TRUE)
+ par(par.set)
+ }
+ row.normalized<-sweep(M, 1, apply(M, 1, sum),FUN="/")
+ row.normalized[is.nan(row.normalized)]<-0
+ plot.mat(M=row.normalized,main=title.row,outer.title=FALSE,...)
+ column.normalized<-sweep(M, 2, apply(M, 2, sum),FUN="/")
+ column.normalized[is.nan(column.normalized)]<-0
+ plot.mat(M=column.normalized,main=title.col,outer.title=FALSE,...)
+ title(main=main.title,outer=TRUE,line=main.title.line)
+ if(!is.null(par.set))par(par.def)
+}
\ No newline at end of file
diff --git a/R/plot.opt.more.par.R b/R/plot.opt.more.par.R
new file mode 100644
index 0000000..dff6f39
--- /dev/null
+++ b/R/plot.opt.more.par.R
@@ -0,0 +1,15 @@
+"plot.opt.more.par" <-
+function(
+ x,#an "opt.par.mode" class object
+ main=NULL,
+ which=1, #which (if there are more than one) of optimal solutions to plot
+ ... #aditional parameters to "plot.mat"
+){
+ if(is.null(main)) main <- deparse(substitute(x))
+ if(which>length(x$best)){
+ warning("The selected (",which,") best solution does not exist!\nOnly ", length(x$best)," best solution(s) exist(s).\nThe first best solution will be ploted.\n")
+ which<-1
+ }
+ plot.mat(x$M,clu=x$best[[which]]$clu,IM=x$best[[which]]$IM,main=main,...)
+}
+
diff --git a/R/plot.opt.more.par.mode.R b/R/plot.opt.more.par.mode.R
new file mode 100644
index 0000000..e29987c
--- /dev/null
+++ b/R/plot.opt.more.par.mode.R
@@ -0,0 +1,15 @@
+"plot.opt.more.par.mode" <-
+function(
+ x,#an "opt.par.mode" class object
+ main=NULL,
+ which=1, #which (if there are more than one) of optimal solutions to plot
+ ... #aditional parameters to "plot.mat"
+){
+ if(is.null(main)) main <- deparse(substitute(x))
+ if(which>length(x$best)){
+ warning("The selected (",which,") best solution does not exist!\nOnly ", length(x$best)," best solution(s) exist(s).\nThe first best solution will be ploted.\n")
+ which<-1
+ }
+ plot.mat(x$M,clu=x$best[[which]]$clu,IM=x$best[[which]]$IM,main=main,...)
+}
+
diff --git a/R/plot.opt.par.R b/R/plot.opt.par.R
new file mode 100644
index 0000000..970b426
--- /dev/null
+++ b/R/plot.opt.par.R
@@ -0,0 +1,15 @@
+"plot.opt.par" <-
+function(
+ x,#an "opt.par.mode" class object
+ main=NULL,
+ which=1, #which (if there are more than one) of optimal solutions to plot
+ ... #aditional parameters to "plot.mat"
+){
+ if(is.null(main)) main <- deparse(substitute(x))
+ if(which>length(x$best)){
+ warning("The selected (",which,") best solution does not exist!\nOnly ", length(x$best)," best solution(s) exist(s).\nThe first best solution will be ploted.\n")
+ which<-1
+ }
+ plot.mat(x$M,clu=x$best[[which]]$clu,IM=x$best[[which]]$IM,main=main,...)
+}
+
diff --git a/R/plot.opt.par.mode.R b/R/plot.opt.par.mode.R
new file mode 100644
index 0000000..d34158c
--- /dev/null
+++ b/R/plot.opt.par.mode.R
@@ -0,0 +1,15 @@
+"plot.opt.par.mode" <-
+function(
+ x,#an "opt.par.mode" class object
+ main=NULL,
+ which=1, #which (if there are more than one) of optimal solutions to plot
+ ... #aditional parameters to "plot.mat"
+){
+ if(is.null(main)) main <- deparse(substitute(x))
+ if(which>length(x$best)){
+ warning("The selected (",which,") best solution does not exist!\nOnly ", length(x$best)," best solution(s) exist(s).\nThe first best solution will be ploted.\n")
+ which<-1
+ }
+ plot.mat(x$M,clu=x$best[[which]]$clu,IM=x$best[[which]]$IM,main=main,...)
+}
+
diff --git a/R/rand.R b/R/rand.R
new file mode 100644
index 0000000..06e6ac2
--- /dev/null
+++ b/R/rand.R
@@ -0,0 +1,7 @@
+"rand" <-
+function (tab) #Hubert & Arabie
+{
+ n <- sum(tab)
+ 1 + (sum(tab^2) - (sum(rowSums(tab)^2) + sum(colSums(tab)^2))/2)/choose(n, 2)
+}
+
diff --git a/R/rand2.R b/R/rand2.R
new file mode 100644
index 0000000..15c059d
--- /dev/null
+++ b/R/rand2.R
@@ -0,0 +1,7 @@
+"rand2" <-
+function (clu1,clu2) #Hubert & Arabie
+{
+ tab<-table(clu1,clu2)
+ 1 + (sum(tab^2) - (sum(rowSums(tab)^2) + sum(colSums(tab)^2))/2)/choose(sum(tab), 2)
+}
+
diff --git a/R/recode.R b/R/recode.R
new file mode 100644
index 0000000..f488848
--- /dev/null
+++ b/R/recode.R
@@ -0,0 +1,10 @@
+"recode" <-
+function(x,oldcode=sort(unique(x)),newcode){
+ if(length(oldcode)!=length(newcode))stop("The number of old and new codes do not match")
+ newx<-x
+ for(i in 1:length(oldcode)){
+ newx[x==oldcode[i]]<-newcode[i]
+ }
+ return(newx)
+}
+
diff --git a/R/reorderImage.R b/R/reorderImage.R
new file mode 100644
index 0000000..97a64ac
--- /dev/null
+++ b/R/reorderImage.R
@@ -0,0 +1,5 @@
+reorderImage<-function(IM,oldClu,newClu){
+if(crand2(oldClu,newClu)!=1)stop("Old and new clu's are not compatibale (crand index is not 1)!\n")
+newOrder<-which(table(oldClu,newClu)>0,arr.ind=TRUE)[,1]
+return(IM[newOrder,newOrder])
+}
diff --git a/R/savecluster.R b/R/savecluster.R
new file mode 100644
index 0000000..e08f5bf
--- /dev/null
+++ b/R/savecluster.R
@@ -0,0 +1,8 @@
+"savecluster" <-
+structure(function(v,filename,cont=FALSE){
+if(length(grep(patt="w32",x=version["os"]))){
+ eol<-"\n"
+}else{eol<-"\r\n"}
+cat(paste(v,collapse=eol),file = filename,append=cont)
+}
+, comment = "Save cluster to file that can be read by Pajek")
diff --git a/R/savematrix.R b/R/savematrix.R
new file mode 100644
index 0000000..ead30e1
--- /dev/null
+++ b/R/savematrix.R
@@ -0,0 +1,47 @@
+"savematrix" <-
+structure(function(n,filename,twomode=1,cont=FALSE){
+if(length(grep(patt="w32",x=version["os"]))){
+ eol<-"\n"
+}else{eol<-"\r\n"}
+if ((dim(n)[1] == dim(n)[2]) & (twomode!=2))
+{
+ verNames<-rownames(n)
+ if(is.null(verNames))verNames<-1:dim(n)[1]
+ verNamesTable<-table(verNames)
+ if(max(verNamesTable)>1){
+ duplicateName<-names(which(verNamesTable>1))
+ for(i in duplicateName){
+ verNames[verNames==i]<-paste(i,1:verNamesTable[i],sep="")
+ }
+ }
+ cat(paste("*Vertices",dim(n)[1]),eol, file = filename,append=cont);
+ cat(paste(seq(1,length=dim(n)[1]),' "',verNames,'"',eol,sep=""), file = filename,append=TRUE);
+ cat("*Matrix",eol, file = filename,append=TRUE);
+ write.table(n,file=filename,eol=eol,row.names = FALSE, col.names = FALSE,append=TRUE)
+}else
+{
+ verRowNames<-rownames(n)
+ if(is.null(verRowNames))verRowNames<-1:dim(n)[1]
+ verRowNamesTable<-table(verRowNames)
+ if(max(verRowNamesTable)>1){
+ duplicateRowName<-names(which(verRowNamesTable>1))
+ for(i in duplicateRowName){
+ verRowNames[verRowNames==i]<-paste(i,1:verRowNamesTable[i],sep="")
+ }
+ }
+ verColNames<-colnames(n)
+ if(is.null(verColNames))verColNames<-1:dim(n)[2]
+ verColNamesTable<-table(verColNames)
+ if(max(verColNamesTable)>1){
+ duplicateColName<-names(which(verColNamesTable>1))
+ for(i in duplicateColName){
+ verColNames[verColNames==i]<-paste(i,1:verColNamesTable[i],sep="")
+ }
+ }
+ cat(paste("*Vertices",sum(dim(n)),dim(n)[1]),eol, file = filename,append=cont);
+ cat(paste(1:dim(n)[1],' "',verRowNames,'"',eol,sep=""), file = filename,append=TRUE);
+ cat(paste(seq(dim(n)[1]+1,length=dim(n)[2]),' "',verColNames,'"',eol,sep=""), file = filename,append=TRUE);
+ cat("*Matrix",eol, file = filename, append=TRUE);
+ write.table(n,file=filename,eol=eol,row.names = FALSE, col.names = FALSE,append=TRUE)
+} }
+, comment = "Save matrix to file that can be read by Pajek (as *Matrix)")
diff --git a/R/savenetwork.R b/R/savenetwork.R
new file mode 100644
index 0000000..d1390ff
--- /dev/null
+++ b/R/savenetwork.R
@@ -0,0 +1,77 @@
+"savenetwork" <-
+structure(function(n,filename,twomode="default",symetric=NULL,cont=FALSE){
+ if(length(grep(patt="w32",x=version["os"]))){
+ eol<-"\n"
+ }else{eol<-"\r\n"}
+ rowNames<-rownames(n)
+ colNames<-colnames(n)
+ if(require(Matrix)){
+ if(class(n)=="mat") n<-unclass(n)
+ n <- as(n,"dgTMatrix")
+ useMatrix<-TRUE
+ }else{
+ pack<-attr(class(n),"package")
+ if(!(is.null(pack))&&pack=="Matrix") stop("The supplied object needs Matrix packege, but the package is not available.")
+ useMatrix<-FALSE
+ }
+ if(dim(n)[1]!=dim(n)[2]){
+ twomode<-2
+ }else if(twomode=="default")twomode<-1
+ if(is.null(symetric))if(twomode==1){
+ if(useMatrix){symetric<-all(n==Matrix::t(n))
+ }else symetric<-all(n==t(n))
+ } else symetric<-FALSE
+ pack<-attr("package",class(n))
+
+ if ((dim(n)[1] == dim(n)[2]) & (twomode!=2)){
+ cat(paste("*Vertices",dim(n)[1]),eol, file = filename,append=cont);
+ cat(paste(seq(1,length=dim(n)[1]),' "',rowNames,'"',eol,sep=""), file = filename,append=TRUE,sep="");
+ if(useMatrix){
+ nDf<-as.data.frame(attributes(n)[c("i","j","x")])
+ nDf[,c("i","j")]<-nDf[,c("i","j")]+1
+ if(symetric){
+ cat("*Edges",eol, file = filename,append=TRUE)
+ nDf<-nDf[nDf$i<=nDf$j,]
+ write.table(nDf[,],eol=eol,file=filename,row.names = FALSE,col.names = FALSE,append=TRUE)
+ } else {
+ cat("*Arcs",eol, file = filename,append=TRUE)
+ write.table(nDf[,],eol=eol,file=filename,row.names = FALSE,col.names = FALSE,append=TRUE)
+ }
+ }else{
+ if(symetric){
+ cat("*Edges",eol, file = filename,append=TRUE)
+ for (i in 1:dim(n)[1]) {
+ for (j in 1:(i)) {
+ if (n[i,j]!=0) {cat(paste(i,j,n[i,j],eol),file = filename,append=TRUE)}
+ }
+ }
+ }else{
+ cat("*Arcs",eol, file = filename,append=TRUE);
+ for (i in 1:dim(n)[1]) {
+ for (j in 1:dim(n)[2]) {
+ if (n[i,j]!=0) {cat(paste(i,j,n[i,j],eol),file = filename,append=TRUE)}
+ }
+ }
+ }
+ }
+ }else {
+ cat(paste("*Vertices",sum(dim(n)),dim(n)[1]),eol, file = filename,append=cont);
+ cat(paste(1:dim(n)[1],' "',rowNames,'"',eol,sep=""), file = filename,append=TRUE);
+ cat(paste(seq(dim(n)[1]+1,length=dim(n)[2]),' "',colNames,'"',eol,sep=""), file = filename,append=TRUE);
+ cat("*Edges",eol, file = filename,append=TRUE);
+ if(useMatrix){
+ nDf<-as.data.frame(attributes(n)[c("i","j","x")])
+ nDf[,c("i","j")]<-nDf[,c("i","j")]+1
+ nDf$j<-nDf$j+dim(n)[1]
+ write.table(nDf[,],eol=eol,file=filename,row.names = FALSE,col.names = FALSE,append=TRUE)
+ }else{
+ for (i in 1:dim(n)[1]) {
+ for (j in 1:dim(n)[2]) {
+ if (n[i,j]!=0) {cat(paste(i,j+dim(n)[1],n[i,j],eol),file = filename,append=TRUE)}
+ }
+ }
+ }
+ }
+
+}
+, comment = "Save matrix to file that can be read by Pajek (as *Arcs)")
diff --git a/R/savepajek.R b/R/savepajek.R
new file mode 100644
index 0000000..4335652
--- /dev/null
+++ b/R/savepajek.R
@@ -0,0 +1,69 @@
+savepajek<-function(pajekList,filename,twomode="default",asMatrix=FALSE,symetric=NULL){
+ if(length(grep(patt="w32",x=version["os"]))){
+ eol<-"\n"
+ }else{eol<-"\r\n"}
+ cat("",file = filename,append=FALSE)
+ pajekListElements<-names(pajekList)
+ if("Networks" %in% pajekListElements){
+ tmpList<-pajekList[["Networks"]]
+ n<-length(tmpList)
+ tmpNames<-names(tmpList)
+ if(is.null(tmpNames)) tmpNames<-1:n
+ for(i in 1:n){
+ if(asMatrix){
+ cat(paste("*Matrix", tmpNames[i]),eol, file = filename,append=TRUE)
+ savematrix(n=tmpList[[i]],filename,twomode=1,cont=TRUE)
+ } else {
+ cat(paste("*Network", tmpNames[i]),eol, file = filename,append=TRUE)
+ savenetwork(n=tmpList[[i]],filename,twomode="default",symetric=NULL,cont=TRUE)
+ }
+ cat(eol, file = filename,append=TRUE)
+ }
+ }
+ if("Partitions" %in% pajekListElements){
+ tmpList<-pajekList[["Partitions"]]
+ n<-length(tmpList)
+ tmpNames<-names(tmpList)
+ if(is.null(tmpNames)) tmpNames<-1:n
+ for(i in 1:n){
+ cat(paste("*Partition", tmpNames[i]),eol, file = filename,append=TRUE)
+ savevector(v=tmpList[[i]],filename,cont=TRUE)
+ cat(eol, file = filename,append=TRUE)
+ }
+ }
+ if("Vectors" %in% pajekListElements){
+ tmpList<-pajekList[["Vectors"]]
+ n<-length(tmpList)
+ tmpNames<-names(tmpList)
+ if(is.null(tmpNames)) tmpNames<-1:n
+ for(i in 1:n){
+ cat(paste("*Vector", tmpNames[i]),eol, file = filename,append=TRUE)
+ savevector(v=tmpList[[i]],filename,cont=TRUE)
+ cat(eol, file = filename,append=TRUE)
+ }
+ }
+
+ if("Permutations" %in% pajekListElements){
+ tmpList<-pajekList[["Permutations"]]
+ n<-length(tmpList)
+ tmpNames<-names(tmpList)
+ if(is.null(tmpNames)) tmpNames<-1:n
+ for(i in 1:n){
+ cat(paste("*Permutation", tmpNames[i]),eol, file = filename,append=TRUE)
+ savevector(v=tmpList[[i]],filename,cont=TRUE)
+ cat(eol, file = filename,append=TRUE)
+ }
+ }
+ if("Clusters" %in% pajekListElements){
+ tmpList<-pajekList[["Clusters"]]
+ n<-length(tmpList)
+ tmpNames<-names(tmpList)
+ if(is.null(tmpNames)) tmpNames<-1:n
+ for(i in 1:n){
+ cat(paste("*Cluster", tmpNames[i]),eol, file = filename,append=TRUE)
+ cat(paste(tmpList[[i]],collapse=eol),file = filename,append=TRUE)
+ cat(eol, file = filename,append=TRUE)
+ }
+ }
+
+}
diff --git a/R/savevector.R b/R/savevector.R
new file mode 100644
index 0000000..1a16921
--- /dev/null
+++ b/R/savevector.R
@@ -0,0 +1,8 @@
+"savevector" <-
+structure(function(v,filename,cont=FALSE){
+if(length(grep(patt="w32",x=version["os"]))){
+ eol<-"\n"
+}else{eol<-"\r\n"}
+cat(paste(c(paste("*Vertices",length(v)), v),collapse=eol),file = filename,append=cont)
+}
+, comment = "Save vector to file that can be read by Pajek")
diff --git a/R/sedist.R b/R/sedist.R
new file mode 100644
index 0000000..bae176f
--- /dev/null
+++ b/R/sedist.R
@@ -0,0 +1,72 @@
+"sedist" <-
+function(
+ M, #matrix (of a network)
+ method="default", # the a method used to compute distances - any of the methods alloed by functions dist, cor or cov {all package::stats} or just "cor" or "cov" (given as character)
+ fun="default", #which function should be used to comput distacnes (given as character),
+ fun.on.rows="default", # for non-standard function - does it compute measure on rows (such as cor, cov,...) of the data matrix.
+# stats.dist.cor.cov=TRUE, #call "stats::dist", "stats::cor" or "stats::cov", not "dist", "cor" or "cov", if nonstandard functions are used, they should exemp the same arguments as those in package stats
+ handle.interaction="switch", #how should the interaction between the vertices analysed be handled:
+ # "switch" (the default) - assumes that when comparing units i and j, M[i,i] should be compared with M[j,j] and M[i,j] with M[j,i]
+ # "switch2" - the same as above, only that each pair occours only once
+ # "ignore" (diagonal) - Diagonal is ignored
+ # "none" - the matrix is used "as is"
+ use = "pairwise.complete.obs", #for use with methods "cor" and "cov", for other methods (the default option should be used if handle.interaction=="ignore"), "pairwise.complete.obs" are always used, if stats.dist.cor.cov=TRUE
+ #p=2 ,#The power of the Minkowski distance in functin dist if stats.dist.cor.cov=TRUE
+ ... #other argumets passed to fun
+)
+{
+ method<-match.arg(method, choices=c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski","pearson", "kendall", "spearman","dist","cor", "cov", "default"))
+ if(any(method=="default", fun=="default")){
+ if(all(method=="default", fun=="default")){
+ fun<-"dist"
+ method<-"euclidean"
+ } else if(fun=="default"){
+ if(method %in% c("pearson", "kendall", "spearman")) fun<-"cor"
+ if(method %in% c("cor", "cov")){
+ fun<-method
+ method<-"pearson"
+ }
+ if(method %in% c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski")) fun<-"dist"
+ } else {
+ if(fun %in% c("cor","cov")) method<-"pearson"
+ if(fun=="dist") method<-"euclidean"
+ }
+ }
+
+ if(handle.interaction=="ignore"&& fun %in% c("cor","cov") && !exists(use))warning("The option use='pairwise.complete.obs' should be used with handle.interaction=='ignore' && fun %in% c('cor','cov')")
+
+# if(fun %in% c("dist", "cor" or "cov") && stats.dist.cor.cov) fun<-paste("stats::",fun,sep="")
+ if(fun.on.rows=="default") if(fun %in% c("cor","cov")){
+ fun.on.rows<-TRUE
+ } else fun.on.rows<-FALSE
+
+ n<-dim(M)[1]
+ if(n!=dim(M)[2]) stop("This function is suited for one-mode networks only")
+ if(fun %in% c("cor", "cov")) usearg<-list(use=use) else usearg<-NULL #usearg
+
+ if(handle.interaction %in% c("switch","switch2")){
+ X<-cbind(M,t(M))
+ n<-dim(M)[1]
+ res<-matrix(NA,ncol=n,nrow=n)
+ for(i in 2:n)for(j in seq(length=(i-1))){
+ jind<-seq(length=2*n)
+ jind[i]<-j
+ jind[j]<-i
+ jind[n+i]<-ifelse(handle.interaction=="switch",n+j,NA)
+ jind[n+j]<-ifelse(handle.interaction=="switch",n+i,NA)
+ Xij<-rbind(X[i,],X[j,jind])
+ if(fun.on.rows)Xij<-t(Xij)
+ res[i,j]<-do.call(fun,args=c(list(x=Xij, method=method,...),usearg))
+ }
+ res<-as.dist(res)
+ }else{
+ if(handle.interaction=="ignore") diag(M)<-NA
+ X<-cbind(M,t(M))
+ if(fun.on.rows)X<-t(X)
+ res<-do.call(fun,args=list(x=X, method=method,...))
+ }
+ if(class(res)=="dist")attr(res,"Labels")<-rownames(M)
+ if(is.matrix(res))dimnames(res)<-dimnames(M)
+ return(res)
+}
+
diff --git a/R/ss.R b/R/ss.R
new file mode 100644
index 0000000..410494a
--- /dev/null
+++ b/R/ss.R
@@ -0,0 +1,3 @@
+"ss" <-
+function(x){sum(x^2)-sum(x)^2/length(x)}
+
diff --git a/R/sumpos.R b/R/sumpos.R
new file mode 100644
index 0000000..3f0215e
--- /dev/null
+++ b/R/sumpos.R
@@ -0,0 +1,3 @@
+"sumpos" <-
+function(v){sum(v[v>0])}
+
diff --git a/R/two2one.R b/R/two2one.R
new file mode 100644
index 0000000..9052a21
--- /dev/null
+++ b/R/two2one.R
@@ -0,0 +1,16 @@
+"two2one" <-
+function(M,clu=NULL){
+ n1<-dim(M)[1]
+ n2<-dim(M)[2]
+ n<-n1+n2
+ M1<-matrix(0,nrow=n,ncol=n)
+ M1[1:n1,(n1+1):n]<-M
+ dimnames(M1)<-list(unlist(dimnames(M)),unlist(dimnames(M)))
+ if(!is.null(clu)) {
+ clu<-lapply(clu,function(x)as.numeric(as.factor(x)))
+ clu[[2]]<-clu[[2]]+max(clu[[1]])
+ clu<-unlist(clu)
+ }
+ return(list(M=M1,clu=clu))
+}
+
diff --git a/R/useneg.R b/R/useneg.R
new file mode 100644
index 0000000..d952ec9
--- /dev/null
+++ b/R/useneg.R
@@ -0,0 +1,3 @@
+"useneg" <-
+function(x)ifelse(x<0,x,0)
+
diff --git a/R/usepos.R b/R/usepos.R
new file mode 100644
index 0000000..582af02
--- /dev/null
+++ b/R/usepos.R
@@ -0,0 +1,3 @@
+"usepos" <-
+function(x)ifelse(x>0,x,0)
+
diff --git a/man/Pajek.Rd b/man/Pajek.Rd
new file mode 100644
index 0000000..53e3a18
--- /dev/null
+++ b/man/Pajek.Rd
@@ -0,0 +1,81 @@
+\name{Pajek}
+\alias{Pajek}
+\alias{loadnetwork}
+\alias{loadnetwork2}
+\alias{loadmatrix}
+\alias{loadvector}
+\alias{loadvector2}
+\alias{loadpajek}
+\alias{savenetwork}
+\alias{savematrix}
+\alias{savevector}
+\alias{savecluster}
+\alias{savepajek}
+\title{Functions for loading and writing Pajek files}
+\description{
+ Functions for reading/loading and writing Pajek files:
+
+ \code{loadnetwork} - Loads a Pajek ".net" filename as a matrix. For now, only simple one and two-mode networks are supported (eg. only single relations, no time information).
+
+ \code{loadnetwork2} - The same as above, but adopted to be called withih \code{loadpajek}
+
+ \code{loadvector} - Loads a Pajek ".clu", ".vec" or ".per" file as a vector.
+
+ \code{loadvector2} - The same as above, but adopted to be called withih \code{loadpajek} - as a consequence not suited for reading clusters
+
+ \code{loadmatrix} - Loads a Pajek ".mat" file as a matrix.
+
+ \code{loadpajek} - Loads a Pajek project filename (".paj") as a list with the following components: Networks, Partitions, Vectors and Clusters. Clusters and hierarchies are dissmised.
+
+ \code{savevector} - Saves a vector, permutation or partition to a Pajek ".clu", ".vec" or ".per" file.
+
+ \code{savenetwork} - Saves a matrix in to a Pajek ".net" file
+
+ \code{savematrix} - Saves a matrix in to a Pajek ".mat" file
+
+ \code{savecluster} - Saves a vector to a Pajek ".cls" file.
+
+ \code{savepajek} - Saves a list of objects to a Pajek ".paj" file.
+}
+
+\usage{
+loadnetwork(filename,useSparseMatrix=NULL,minN=50)
+loadnetwork2(filename,useSparseMatrix=NULL,minN=50)
+loadmatrix(filename)
+loadvector(filename)
+loadvector2(filename)
+loadpajek(filename)
+
+savenetwork(n, filename, twomode = "default", symetric = NULL, cont=FALSE)
+savematrix(n, filename, twomode = 1, cont=FALSE)
+savevector(v, filename, cont=FALSE)
+savecluster(v, filename, cont=FALSE)
+savepajek(pajekList,filename,twomode="default",asMatrix=FALSE,symetric=NULL)
+
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{filename}{The name of the filename to be loaded or saved to or an open file object.}
+ \item{useSparseMatrix}{Should a sparse matrix be use instead of the ordinary one? Sparse matices can only be used if package Matrix is installed. The default \code{NULL} uses sparsematrices for networks with more that \code{minN} vertices}
+ \item{minN}{The minimal number of units in the network to use sparse matrices.}
+ \item{n}{A matrix representing the network.}
+ \item{twomode}{1 for one-mode networks and 2 for two-mode networks. Default sets the argument to 1 for square matrices and to 2 for others.}
+ \item{symetric}{If true, only the lower part of the matrix is used and the values are interpreted as "Edges", not "Arcs". When used in \code{savepajek} function it applies to all networks.}
+ \item{v}{A vector}
+ \item{cont}{A logical constant indicating if the output should be appended to a file instead of creating a new file. Included so that the function could be used within \code{savepajek} function. Not intended to be used/set by user.}
+ \item{pajekList}{A list containing one or more lists with the following names (exact): "Networks", "Partitions", "Vectors", "Permutations" and "Clusters". Each list should contain elements that correspond to Pajek objects ("Networks" matrices and the other lists vectors), meaning that they can be written to Pajek files using the other save* functions . The content is written to Pajek ".paj" file.}
+ \item{asMatrix}{A logical constant indicating if the networks should be written in matrix format (as in ".mat" file) instead in the network (*Arcslist or *Edgelist) format (as in ".mat" file).}
+}
+\value{
+ NULL, a matrix or a vector (see Description)
+}
+\references{
+Pajek (
+V. Batagelj, A. Mrvar: Pajek - Program for Large Network Analysis. Home page \url{http://vlado.fmf.uni-lj.si/pub/networks/pajek/}.
+
+W. de Nooy, A. Mrvar, V. Batagelj: Exploratory Social Network Analysis with Pajek, CUP, January 2005
+}
+\author{Vladimir Batagelj & Andrej Mrvar (most functions), \enc{Aleš Žiberna}{Ales Ziberna} (\code{loadnetwork}, \code{loadpajek} and modification of others)}
+\seealso{\code{\link{plot.mat}}, \code{\link{crit.fun}}, \code{\link{opt.par}}, \code{\link{opt.random.par}}, \code{\link{opt.these.par}}, \code{\link{check.these.par}}}
+\keyword{graphs}% at least one, from doc/KEYWORDS
+\keyword{file}% at least one, from doc/KEYWORDS
diff --git a/man/REGE.Rd b/man/REGE.Rd
new file mode 100644
index 0000000..648df6a
--- /dev/null
+++ b/man/REGE.Rd
@@ -0,0 +1,117 @@
+\name{REGE}
+\alias{REGE}
+\alias{REGE.for}
+\alias{REGE.nm.for}
+\alias{REGE.ow}
+\alias{REGE.ow.for}
+\alias{REGE.ownm.for}
+\alias{REGD.for}
+\alias{REGD.ow.for}
+\alias{REGE.FC}
+\alias{REGE.FC.ow}
+\alias{REGD.ne.for}
+\alias{REGD.ow.ne.for}
+\alias{REGE.ne.for}
+\alias{REGE.nm.diag.for}
+\alias{REGE.nm.ne.for}
+\alias{REGE.ow.ne.for}
+\alias{REGE.ownm.diag.for}
+\alias{REGE.ownm.ne.for}
+
+
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{REGE - Algorithms for compiting (dis)similarities in terms of regular equivalnece.}
+\description{
+REGE - Algorithms for compiting (dis)similarities in terms of regular equivalnece (White and Reitz, 1983):
+
+\code{REGE, REGE.for} - Classical REGE or REGGE, as also implemented in Ucinet. Similarities in terms of regular equivalnece are computed. The \code{REGE.for} is a wraper for calling the FORTRAN subrutine writen by White (1985a), modified to be called by R. The \code{REGE} does the same, however it is written in R. The functions with and without ".for" differ only in wheater they are implemeted in R of FORTRAN. Needless to say, the funcitons implemeted in FORTRAN are much faster.
+
+\code{REGE.ow, REGE.ow.for} - The above function, modified so that a best match is searhed for for each arc speleratly (and not for both arcs, if they exist, together)
+
+\code{REGE.nm.for} - REGE or REGGE, modified to to use row and column normalited matrices instead of the original matrix.
+
+\code{REGE.ownm.for} - The above function, modified so that a best match is searhed for for each arc speleratly (and not for both arcs, if they exist, together)
+
+\code{REGD.for} - REGD or REGDI, a dissimilarity version of the classical REGE or REGGE. Dissimilarities in terms of regular equivalnece are computed. The \code{REGD.for} is a wraper for calling the FORTRAN subrutine writen by White (1985b), modified to be called by R.
+
+\code{REGE.FC} - Acctually an erlier version of REGE. The diference is in the denominator. See Žiberna (2006) for details.
+
+\code{REGE.FC.ow} - The above function, modified so that a best match is searhed for for each arc speleratly (and not for both arcs, if they exist, together)
+
+other - still in testing stage
+}
+\usage{
+REGE(M, E = 1, iter = 3, until.change = TRUE, use.diag = TRUE)
+REGE.for(M, iter = 3, E = 1)
+REGE.nm.for(M, iter = 3, E = 1)
+REGE.ow(M, E = 1, iter = 3, until.change = TRUE, use.diag = TRUE)
+REGE.ow.for(M, iter = 3, E = 1)
+REGE.ownm.for(M, iter = 3, E = 1)
+REGD.for(M, iter = 3, E = 0)
+REGD.ow.for(M, iter = 3, E = 0)
+REGE.FC(M, E = 1, iter = 3, until.change = TRUE, use.diag = TRUE,
+ normE = FALSE)
+REGE.FC.ow(M, E = 1, iter = 3, until.change = TRUE,
+ use.diag = TRUE, normE = FALSE)
+REGD.ne.for(M, iter = 3, E=0)
+REGD.ow.ne.for(M, iter = 3, E = 0)
+REGE.ne.for(M, iter = 3, E=1)
+REGE.nm.diag.for(M, iter = 3, E=1)
+REGE.nm.ne.for(M, iter = 3, E=1)
+REGE.ow.ne.for(M, iter = 3, E=1)
+REGE.ownm.diag.for(M, iter = 3, E=1)
+REGE.ownm.ne.for(M, iter = 3, E=1)
+}%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{Matrix or a 3 dimensional array representing the network. The third dimension allows for several relations to be analyzed.}
+ \item{E}{Initial (dis)similarity in terms of regular equivalnece.}
+ \item{iter}{The desired number of itetations}
+ \item{until.change}{Should the iterations be stop when no change occours}
+ \item{use.diag}{Should the diagonal be used. If \code{FALSE}, all diagonal elements are set to 0.}
+ \item{normE}{Should the equivalence matrix be normalized after each iteration?}
+}
+\value{
+ \item{E}{A matrix of (dis)similarities in terms of regular equivalnece}
+ \item{Eall }{An array of (dis)similarity matrices in terms of regular equivalnece, each third dimmension represets one iteration. For ".for" functions, only the initial and the final (dis)similarities are returned.}
+ \item{M}{Matrix or a 3 dimensional array representing the network used in the call.}
+ \item{iter}{The desired number of itetations}
+ \item{use.diag}{Should the diagonal be used - for functions implemeted in R only.}
+ ...
+}
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+
+White, D. R., K. P. Reitz (1983): "Graph and semigroup homomorphisms on networks of relations". Social Networks, 5, p. 193-234.
+
+White, Douglas R.(1985a): DOUG WHITE'S REGULAR EQUIVALENCE PROGRAM. \url{http://eclectic.ss.uci.edu/~drwhite/REGGE/REGGE.FOR} (12.5.2005).
+
+White, Douglas R.(1985b): DOUG WHITE'S REGULAR DISTANCES PROGRAM. \url{http://eclectic.ss.uci.edu/~drwhite/REGGE/REGDI.FOR} (12.5.2005).
+
+White, Douglas R.(2005): REGGE (web page). \url{http://eclectic.ss.uci.edu/~drwhite/REGGE/} (12.5.2005).
+}
+\author{\enc{Aleš Žiberna}{Ales Ziberna} based on Douglas R. White's original REGE and REGD}
+\seealso{\code{\link{sedist}}, \code{\link{crit.fun}}, \code{\link{opt.par}}, \code{\link{plot.mat}}}
+\examples{
+n<-20
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(5,15))
+tclu<-table(clu)
+net[clu==1,clu==1]<-0
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],
+ mean=4,sd=1)*sample(c(0,1),
+ size= tclu[1]*tclu[2],replace=TRUE,prob=c(3/5,2/5))
+net[clu==2,clu==1]<-0
+net[clu==2,clu==2]<-0
+
+D<-REGE.for(M=net)$E #any other REGE function can be used
+plot.mat(net, clu=cutree(hclust(d=as.dist(1-D),method="ward"),
+ k=2))
+#REGE returns similarities, which have to be converted to
+#disimilarities
+
+res<-opt.random.par(M=net,k=2,rep=10,approach="ss",blocks="reg",
+ FUN="max")
+plot(res) #Hopefully we get the original partition
+}
+\keyword{cluster}% at least one, from doc/KEYWORDS
+\keyword{graphs}% at least one, from doc/KEYWORDS
diff --git a/man/blockmodeling-package.Rd b/man/blockmodeling-package.Rd
new file mode 100644
index 0000000..d456334
--- /dev/null
+++ b/man/blockmodeling-package.Rd
@@ -0,0 +1,86 @@
+\name{blockmodeling-package}
+\alias{blockmodeling-package}
+\docType{package}
+\title{
+An R package for Generalized and classical blockmodeling of valued networks
+}
+\description{
+This package is primarily meant as an implementation of Generalized blockmodeling. In addition, functions for computation of (dis)similarities in terms of structural and regular equivalence, plotting and other "utility" functions are provided.
+}
+%\details{
+%~~ An overview of how to use the package, including the most important functions ~~
+%}
+\author{
+\enc{Aleš Žiberna}{Ales Ziberna}
+}
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2006): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+
+DOREIAN, Patrick, BATAGELJ, Vladimir, FERLIGOJ, \enc{Anuška}{Anuska} (2005): Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press, 2005. XV, 384 p., ISBN 0-521-84085-6.
+
+White, D. R., K. P. Reitz (1983): "Graph and semigroup homomorphisms on networks of relations". Social Networks, 5, p. 193-234.
+
+White, Douglas R.(2005): REGGE (web page). \url{http://eclectic.ss.uci.edu/~drwhite/REGGE/} (12.5.2005).
+}
+\keyword{ package }
+\keyword{cluster}% at least one, from doc/KEYWORDS
+\keyword{graphs}% at least one, from doc/KEYWORDS
+
+\seealso{
+Packages:
+\code{\link[sna:sna]{sna}}
+\code{\link[network:network-package]{network}}
+
+Functions inside this package:
+\code{\link{crit.fun}}, \code{\link{opt.par}}, \code{\link{opt.random.par}}, \code{\link{opt.these.par}}, \code{\link{check.these.par}}, \code{\link{REGE}}, \code{\link{plot.mat}}
+}
+\examples{
+n<-8 #if larger, the number of partitions increases dramaticaly,
+# as does if we increase the number of clusters
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(3,5))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+#we select a random parition and then optimise it
+
+all.par<-nkpartitions(n=n, k=length(tclu))
+#forming the partitions
+all.par<-lapply(apply(all.par,1,list),function(x)x[[1]])
+# to make a list out of the matrix
+
+#optimizing one partition
+res<-opt.par(M=net,
+ clu=all.par[[sample(1:length(all.par),size=1)]],
+ approach="ss", blocks="com")
+plot(res) #Hopefully we get the original partition
+
+#optimizing 10 random partitions which with opt.these.par
+res<-opt.these.par(M=net,
+ partitions=all.par[sample(1:length(all.par),size=10)],
+ approach="ss",blocks="com")
+plot(res) #Hopefully we get the original partition
+
+#optimizing 10 random partitions with opt.random.par
+res<-opt.random.par(M=net,k=2,rep=10,approach="ss",blocks="com")
+plot(res) #Hopefully we get the original partition
+
+#Checking all possible partitions
+nkpar(n=n, k=length(tclu)) #computing the number of partitions
+all.par<-nkpartitions(n=n, k=length(tclu))
+#forming the partitions
+all.par<-lapply(apply(all.par,1,list),function(x)x[[1]])
+# to make a list out of the matrix
+res<-check.these.par(M=net,partitions=all.par,approach="ss",
+ blocks="com")
+plot(res) #we get the original partition
+
+#using indidect approach - structural equivalence
+D<-sedist(M=net)
+plot.mat(net, clu=cutree(hclust(d=D,method="ward"),k=2))
+}
diff --git a/man/check.these.par.Rd b/man/check.these.par.Rd
new file mode 100644
index 0000000..14d013c
--- /dev/null
+++ b/man/check.these.par.Rd
@@ -0,0 +1,72 @@
+\name{check.these.par}
+\alias{check.these.par}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Computes the value of a criterion function for a given network and a set of partitions}
+\description{
+The function computes the value of a criterion function for a given network and a set of partitions for Generalized blockmodeling. (Žiberna, 2006) based on other parameters (see below and \code{\link{crit.fun}}).
+}
+\usage{
+check.these.par(M, partitions, approach, return.err = TRUE,
+ save.initial.param = TRUE, force.fun = NULL, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network can have one or more modes (diferent kinds of units with no ties among themselvs. If the network is not two-mode, the matrix must be square.}
+ \item{partitions}{A list of partitions. Each unique value represents one cluster. If the nework is one-mode, than this should be a vector, else a list of vectors, one for each mode.}
+ \item{approach}{One of the approaches described in Žiberna (2006). Possible values are:\cr
+ "bin" - binary blockmodeling,\cr
+ "val" - valued blockmodeling,\cr
+ "imp" - implicit blockmodeling,\cr
+ "ss" - sum of squares homogenity blockmodeling, and\cr
+ "ad" - absolute deviations homogenity blockmodeling.}
+ \item{return.err}{Should the error for each evaluated partition be returned}
+ \item{save.initial.param}{Should the inital parameters (\code{approach},...)}
+ \item{force.fun}{Select the function used to evaluate the network and a partition. This should be used only in exterem cases. Otherwise, the appropriate function is selected (generated) besed on the input parameters.}
+ \item{\dots}{Argumets to \code{gen.crit.fun} see \code{\link{crit.fun}} for description. Some are required!!!}
+}
+\value{
+ \item{M}{The matrix of the network analyzed}
+ \item{best}{A list of results from \code{crit.fun.tmp} with the same elements as the result of \code{crit.fun}, only without \code{M}}
+ \item{err}{If selected - The vector of errors or inconsistencies of the emplirical network with the ideal network for a given blockmodel (model,approach,...) and parititions}
+ \item{call}{The call used to call the function.}
+ \item{initial.param}{If selected - The inital parameters used.}
+ ...
+}
+\section{Warning }{
+This function is usually used to check all possible partitions. If the number of partitions is large (several 1000), this can be extremly time demanding. It is advaisable to firtst time the function on a smaller subset.
+}
+
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2006): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+
+DOREIAN, Patrick, BATAGELJ, Vladimir, FERLIGOJ, \enc{Anuška}{Anuska} (2005): Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press, 2005. XV, 384 p., ISBN 0-521-84085-6.
+}
+
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{crit.fun}}, \code{\link{opt.par}}, \code{\link{opt.these.par}}, \code{\link{nkpartitions}}, \code{\link{plot.check.these.par}} }
+
+\examples{
+n<-8 # if larger, the number of partitions increases dramaticaly,
+ # as does if we increase the number of clusters
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(3,5))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+#computation of criterion function with the correct partition
+nkpar(n=n, k=length(tclu)) #computing the number of partitions
+all.par<-nkpartitions(n=n, k=length(tclu))
+#forming the partitions
+all.par<-lapply(apply(all.par,1,list),function(x)x[[1]])
+# to make a list out of the matrix
+res<-check.these.par(M=net,partitions=all.par,approach="ss",
+ blocks="com")
+plot(res) #we get the original partition
+}
+\keyword{cluster}% at least one, from doc/KEYWORDS
+\keyword{graphs}% at least one, from doc/KEYWORDS
diff --git a/man/clu.Rd b/man/clu.Rd
new file mode 100644
index 0000000..d2f4d5b
--- /dev/null
+++ b/man/clu.Rd
@@ -0,0 +1,62 @@
+\name{clu}
+\alias{clu}
+\alias{partitions}
+\alias{IM}
+\alias{err}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Function for extraction of some elements for objects, returend by functions for Generalized blockmodeling}
+\description{
+Function for extraction of clu (partition), all best clus (partitions), IM (image or blockmodel) and err (total error or inconsistency) for objects, returend by functions \code{\link{opt.par}}, \code{\link{opt.random.par}}, \code{\link{opt.these.par}}, and \code{\link{check.these.par}}
+}
+\usage{
+clu(res, which = 1, ...)
+IM(res, which = 1, ...)
+err(res, ...)
+partitions(res)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{res}{Resoult of function \code{\link{opt.par}}, \code{\link{opt.random.par}}, \code{\link{opt.these.par}}, or \code{\link{check.these.par}}}
+ \item{which}{From which (if there are more than one) "best" solution whould the element be extracted. Warning! \code{which} grater than the number of "best" partitions produces an error.}
+ \item{\dots}{Not used}
+}
+\value{
+ The desired element.
+}
+
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2006): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+
+DOREIAN, Patrick, BATAGELJ, Vladimir, FERLIGOJ, \enc{Anuška}{Anuska} (2005): Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press, 2005. XV, 384 p., ISBN 0-521-84085-6.
+}
+
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{crit.fun}}, \code{\link{check.these.par}}, \code{\link{opt.random.par}}, \code{\link{opt.these.par}}, \code{\link{plot.opt.par}}}
+\examples{
+n<-8 #if larger, the number of partitions increases dramaticaly,
+ #as does if we increase the number of clusters
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(3,5))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+#we select a random parition and then optimise it
+
+all.par<-nkpartitions(n=n, k=length(tclu))
+#forming the partitions
+all.par<-lapply(apply(all.par,1,list),function(x)x[[1]])
+# to make a list out of the matrix
+res<-opt.par(M=net,
+ clu=all.par[[sample(1:length(all.par),size=1)]],
+ approach="ss",blocks="com")
+plot(res) #Hopefully we get the original partition
+clu(res) #Hopefully we get the original partition
+err(res) #Error
+IM(res) #NULL, because FORTRAN subrutine is used.
+}
+\keyword{manip}% at least one, from doc/KEYWORDS
diff --git a/man/crit.fun.Rd b/man/crit.fun.Rd
new file mode 100644
index 0000000..6ccaa3a
--- /dev/null
+++ b/man/crit.fun.Rd
@@ -0,0 +1,135 @@
+\name{crit.fun}
+\alias{crit.fun}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Computes the criterion function for a given network and partition}
+\description{
+The function computes the value of a criterion function for a given network and partition for Generalized blockmodeling. (Žiberna, 2006) based on other parameters (see below).
+}
+\usage{
+crit.fun(M, clu, approach, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{A matrix representing the (usually valued) network. For multi-relational networks, this should be an array with the third dimension representing the relation. The network can have one or more modes (diferent kinds of units with no ties among themselvs. If the network is not two-mode, the matrix must be square.}
+ \item{clu}{A partition. Each unique value represents one cluster. If the nework is one-mode, than this should be a vector, else a list of vectors, one for each mode}
+ \item{approach}{One of the approaches (for each relation in multi-relational netowrks in a vector) described in Žiberna (2006). Possible values are:\cr
+ "bin" - binary blockmodeling,\cr
+ "val" - valued blockmodeling,\cr
+ "imp" - implicit blockmodeling,\cr
+ "ss" - sum of squares homogenity blockmodeling, and\cr
+ "ad" - absolute deviations homogenity blockmodeling.}
+ \item{\dots}{Several other arguments, which are explaind below. They are actually used by the function \code{gen.crit.fun}, however since this function is not intented to be called directly, it also has no help files. Therefore these arguments are described below. Which are needed depends on the \code{approach} selected:\cr\cr
+ \bold{\code{blocks}}: A vector with names of allowed blocktypes. For multi-relational networks, it can be a list of such vectors. For approaches "bin", and "val", at least two should be selected. Possible values are are:\cr
+ "null" - null or empty block\cr
+ "com" - complete block\cr
+ "rdo", "cdo" - row and column-dominant blocks (binary, valued, and implicit approach only)\cr
+ "reg" - (f-)regular block\cr
+ "rre", "cre" - row and column-(f-)regular blocks\cr
+ "rfn", "cfn" - row and column-dominant blocks (binary, valued, and implicit approach only)\cr
+ "den" - density block (binary approach only)\cr
+ "avg" - average block (valued and implicit approach only)\cr
+ "dnc" - do not care block - the error is always zero\cr
+ The ordering is important, since if several block types have identical error, the first on the list is selected.\cr\cr
+ \bold{\code{BLOCKS}}: An alternative to \code{blocks}. A pre-specified blockmodel. An array with dimensions three dimensions (see example below). The second and the third repreent the clusters (for rows and columns), while the first is as long as the maxsimum number of allows block types for a given block. If some block has less possible block types, the empty slots should have values \code{NA}. The values in the array should be the ones from above. For multi-relational networks, it c [...]
+ \bold{\code{m}}: Suficient value for individual cells for valued approach. Can be a number or a character string giving the name of a function. Set to \code{"max"} for implicit approach. For multi-relational networks, it can be a vector of such values.\cr\cr
+ \bold{\code{cut}}: (default = \code{min(M[M > 0])}) The threshold used for binerizing the network for use with binary blockmodeling. All values with values lower than \code{cut} are recoded into 0s, all other into 1s. For multi-relational networks, it can be a vector of such values.\cr\cr
+ \bold{\code{FUN}}: (default = "max") Function f used in row-f-regular, column-f-regular, and f-regular blocks. Not used in binary approach. For multi-relational networks, it can be a vector of such character strings.\cr\cr
+ \bold{\code{norm}}: Should the block errors (inconsistencies) be normalized with the size of the blocks, the block error does not depend on block size? The default is \code{FALSE}. Original version of implicit approach suggests \code{TRUE}, however the default is \code{FALSE} even for this approach based on better results in simulations. For multi-relational networks, it can be a vector.\cr\cr
+ \bold{\code{normbym}}: The default is \code{FALSE} for valued and implicit approach, elsewher not used. Original version of implicit approach suggests \code{TRUE}, however the default is \code{FALSE} even for this approach based on better results in simulations. For multi-relational networks, it can be a vector.\cr\cr
+ \bold{\code{allow.max0}}: Should the maximum that is the basis for calculation of inconsistencies in implicit blockmodeling be allowed to be 0. If FALSE, the maximum is in such case set to the maximum of the network (if maximum of a block is 0) or to the maxsimum of the block (if row or column maxismum is 0)Used only in implicit blockmodeling. If \code{TRUE}, the incosistency of an ideal null block is 0 for all block types. The default is \code{FALSE} if null blocks are incluede in th [...]
+ \bold{\code{allow.dom0}}: Should the dominant row or column (in row- or column-dominant blocks) be allowed to be 0. Used only in implicit blockmodeling. The default is \code{FALSE}.\cr\cr
+ \bold{\code{normMto2rel}}: Create two-realation netowrk from one relational network through row and column normalization. The default is \code{FALSE}:\cr\cr
+ \bold{\code{sameModel}}: Should we damand the same blockmodel for all relations. If set to TRUE, it demands that accros all relations the ideal block on the same position in the matrix BLOCKS should be chosen. Usually, these positions are occupied by the same blocks. If not, use with caution. The default is the value of \code{normMto2rel}.\cr\cr
+ \bold{\code{max.con.val}}: Should the largest values be cencored, limited to (larger values set to) - resonoble values are:
+ "non" - (the default) no transformation is done\cr
+ "m" - (the default for implicit blockmodeling) the maximum value equals the value of the parameter m\cr
+ numerical values (usually) larger then parameter m and lower the the maximum value in M.\cr\cr
+
+
+ \bold{\code{mindim}}: (default = 2) Minimal dimension (number of rows or columns) demanded for row and column-dominant and -functional blocks.\cr\cr
+ \bold{\code{mindimreg}}: (default = \code{FALSE}) Should the mindim argument also be used for (row or coulum-)(f-)regular blocks\cr\cr
+ \bold{\code{blockWeights}}: Weights for each type of block used, if they are to be different accros block types (see \code{blocks} above). It must be suplied in form of a named vetor\cr \code{blockWeights = c(name.of.block.type1=weight,...)}\cr If some of the block types used are not listed, they are given weight 1.\cr\cr
+ \bold{\code{positionWeights}}: weigths for positions in the blockmodel (the dimensions must be the same as the error matrix). For now this is a matix (two-dimensional) even for multi-relational networks.\cr\cr
+ \bold{\code{save.err.v}}: (default = \code{FALSE}) Should the error vector for all allowed block types in each block be saved?\cr\cr
+ \bold{\code{BLOCK.CV}}: An array with the same dimmesions as \code{BLOCKS} of central values for pre-specified homogenity (sum of squares and absolute deviations) approach. For multi-relational networks, it can be a list of such arrays.\cr\cr
+ \bold{\code{CV.use}}: An array with the same dimmesions as \code{BLOCKS.CV} with instuctions how to treat these centarl values. For multi-relational networks, it can be a list of such arrays. Possible alternatives are:\cr
+ "fixed" - the central value is fixed to the value specified in \code{BLOCKS.CV}.\cr
+ "min" - the central value specified in \code{BLOCKS.CV} is the minimal possible central value for a block. The central value for the block is computed as the maximum of the value specified in \code{BLOCKS.CV} and the empirical value computed based on tie values in the block.\cr
+ "max" - the central value specified in \code{BLOCKS.CV} is the maximal possible central value for a block. The central value for the block is computed as the minimum of the value specified in \code{BLOCKS.CV} and the empirical value computed based on tie values in the block.\cr
+ "free" - the central value is free, the value specified in \code{BLOCKS.CV} is igneored. The central value for the block is computed as the empirical value computed based on tie values in the block.\cr\cr
+ \bold{\code{use.for}}: (default = \code{TRUE}) Should FORTRAN subrutines be used where available (available for only very special cases, currently only for using "ss" aproach and only complete blocks. If you are using such setting and some special features (these are not implemented in FORTRAN subrutines), it's safer to set it to FASLE, as the fuction may miss that these features are not implemented in FORTRAN subrutines and use them nevertheless, leading to wrong results.\cr
+ \bold{\code{diag}}: (default = \code{TRUE}) Should the special stauts of diagonal be acknowladged.
+ }
+}
+%\details{
+%}
+\value{
+ A list:
+ \item{M}{The matrix of the network analyzed}
+ \item{err}{The error or inconsistency emplirical network with the ideal network for a given blockmodel (model,approach,...) and paritition}
+ \item{clu}{The analyzed partition}
+ \item{E}{Block errors by blocks}
+ \item{IM}{The obtained image}
+ \item{BM}{Block means by block - only for Homogeneity blockmodeling}
+ \item{ERR.V}{If selected. The error vector of errors for all allowed block types by blocks. The dimmensions are [rows, columns (,relations - if more than 1)]. Each cell contains a list of errors by block types}
+}
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2006): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+
+DOREIAN, Patrick, BATAGELJ, Vladimir, FERLIGOJ, \enc{Anuška}{Anuska} (2005): Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press, 2005. XV, 384 p., ISBN 0-521-84085-6.
+}
+
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{opt.par}}, \code{\link{opt.random.par}}, \code{\link{opt.these.par}}, \code{\link{check.these.par}}, \code{\link{plot.crit.fun}}}
+\examples{
+#generating a simple network corresponding to the simple Sum of squares
+#structural equivalence with blockmodel:
+# null com
+# null null
+n<-20
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(5,15))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+#computation of criterion function with the correct partition
+res<-crit.fun(M=net,clu=clu,approach="ss",blocks="com")
+res$err #the error is relativly small
+res$BM #The block means are around 0 or 4
+plot(res)
+
+#computation of criterion function with random partition
+clu.rnd<-sample(1:2,size=n,replace=TRUE)
+res.rnd<-crit.fun(M=net,clu=clu.rnd,approach="ss",blocks="com")
+res.rnd$err #the error is larger
+res.rnd$BM #random block means
+plot(res.rnd)
+
+#adapt network for Valued blockmodeling with the same model
+net[net>4]<-4
+net[net<0]<-0
+
+#computation of criterion function with the correct partition
+res<-crit.fun(M=net,clu=clu,approach="val",
+ blocks=c("null","com"),m=4)
+res$err #the error is relativly small
+res$IM
+#The image corresponds to the one used for generation of
+#the network
+plot(res)
+
+#computation of criterion function with random partition
+res.rnd<-crit.fun(M=net,clu=clu.rnd,approach="val",
+ blocks=c("null","com")
+ , m=4)
+res.rnd$err #the error is larger
+res.rnd$IM #all blocks are probably null
+plot(res.rnd)
+}
+\keyword{cluster}% at least one, from doc/KEYWORDS
+\keyword{graphs}% at least one, from doc/KEYWORDS
diff --git a/man/find.m.Rd b/man/find.m.Rd
new file mode 100644
index 0000000..3900c64
--- /dev/null
+++ b/man/find.m.Rd
@@ -0,0 +1,55 @@
+\name{find.m}
+\alias{find.m}
+\alias{find.m2}
+\alias{find.cut}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Computing the threshold}
+\description{
+The functions compute the maxsimum value of \code{m/cut} where a ceratin block is still classified as \code{alt.blocks} and not "null".
+The difference between \code{find.m} and \code{find.m2} it that \code{find.m} uses an optimizational approach and is faster and more precise than \code{find.m2}. However, \code{find.m} only supports regular ("reg") and complete ("com") as \code{alt.blocks}, while \code{find.m2} supports all block types. Also, \code{find.m} does not always work, sepecially if \code{cormat} is not "none".
+}
+\usage{
+find.m(M, clu, alt.blocks = "reg", diag = !is.list(clu),
+ cormet = "none", half = TRUE, FUN = "max")
+find.m2(M, clu, alt.blocks = "reg", neval = 100, half = TRUE,
+ ms = NULL, ...)
+find.cut(M, clu, alt.blocks = "reg", cuts = "all", ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network can have one or more modes (diferent kinds of units with no ties among themselvs. If the network is not two-mode, the matrix must be square.}
+ \item{clu}{A partition. Each unique value represents one cluster. If the nework is one-mode, than this should be a vector, else a list of vectors, one for each mode}
+ \item{alt.blocks}{Only one of allowed blocktypes, as alternative to the null block:\cr
+ "com" - complete block\cr
+ "rdo", "cdo" - row and column-dominant blocks (binary, valued, and implicit approach only)\cr
+ "reg" - (f-)regular block\cr
+ "rre", "cre" - row and column-(f-)regular blocks\cr
+ "rfn", "cfn" - row and column-dominant blocks (binary, valued, and implicit approach only)\cr
+ "den" - density block (binary approach only)\cr
+ "avg" - average block (valued approach only)}
+ \item{diag}{(default = \code{TRUE}) Should the special stauts of diagonal be acknowladged.}
+ \item{cormet}{Which metho should be used to correct for diferent maxismum error contributins?\cr
+ "none" - no correction\cr
+ "censor" - censor values larger than m\cr
+ "correct" - so that the maxsimum possible error contribution of the cell is the same regardles of a condition (either that somthing must be o or at least m)}
+ \item{FUN}{(default = "max") Function f used in row-f-regular, column-f-regular, and f-regular blocks.}
+ \item{cuts}{The cuts which should be evaluatated. If \code{cuts="all"n} (default), all unique values are evaluated}
+ \item{neval}{Number of different \code{m} values to be evaluated.}
+ \item{half}{Should the returned value of m be one half of the value where the incosnistencies are the same.}
+ \item{ms}{The values of m where the function should be evaluated.}
+ \item{\dots}{Other parameters to crit.fun}
+}
+\value{
+ A matrix of maximal \code{m/cut} values.
+}
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2006): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+
+DOREIAN, Patrick, BATAGELJ, Vladimir, FERLIGOJ, \enc{Anuška}{Anuska} (2005): Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press, 2005. XV, 384 p., ISBN 0-521-84085-6.
+}
+
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{crit.fun}} and maybe also \code{\link{opt.par}}, \code{\link{plot.mat}}}
+\keyword{cluster}% at least one, from doc/KEYWORDS
diff --git a/man/formatA.Rd b/man/formatA.Rd
new file mode 100644
index 0000000..f235228
--- /dev/null
+++ b/man/formatA.Rd
@@ -0,0 +1,27 @@
+\name{formatA}
+\alias{formatA}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{A formating function for numbers}
+\description{
+Formats a vector or matrix of numbers so that all have equal length (digits). This is especially suitable for printing tables.
+}
+\usage{
+formatA(x, digits = 2, FUN = round, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{A numerical vector or matric}
+ \item{digits}{The number of desired digits}
+ \item{FUN}{Function used for "shortening" the numbers.}
+ \item{\dots}{Additional arguments to \code{format}}
+}
+\value{
+A character vector or matrix.
+}
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{find.m}}, \code{\link{find.m2}}, \code{\link{find.cut}}}
+\examples{
+A<-matrix(c(1,1.02002,0.2,10.3),ncol=2)
+formatA(A)
+}
+\keyword{character}% at least one, from doc/KEYWORDS
diff --git a/man/fun.by.blocks.Rd b/man/fun.by.blocks.Rd
new file mode 100644
index 0000000..1dd8409
--- /dev/null
+++ b/man/fun.by.blocks.Rd
@@ -0,0 +1,75 @@
+\name{fun.by.blocks}
+\alias{fun.by.blocks}
+\alias{fun.by.blocks.default}
+\alias{fun.by.blocks.mat}
+\alias{fun.by.blocks.opt.more.par}
+
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Computation of function values by blocks}
+\description{
+Computes a value of a functions over blocks of a matrix, defined by a partition.
+}
+\usage{
+fun.by.blocks(x, ...)
+
+\method{fun.by.blocks}{default}(x = M, M = x, clu,
+ ignore.diag = identical(ss(diag(M)), 0) && !is.list(clu),
+ FUN = "mean", sortNames = TRUE, ...)
+
+\method{fun.by.blocks}{opt.more.par}(x, which = 1, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{An object of suitable class or a matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network can have one or more modes (diferent kinds of units with no ties among themselvs. If the network is not two-mode, the matrix must be square.}
+ \item{M}{A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network can have one or more modes (diferent kinds of units with no ties among themselvs. If the network is not two-mode, the matrix must be square.}
+ \item{clu}{A partition. Each unique value represents one cluster. If the nework is one-mode, than this should be a vector, else a list of vectors, one for each mode}
+ \item{ignore.diag}{Should the diagonal be ingored. }
+ \item{sortNames}{Should the rows and columns of the matrix be sorted based on their names?}
+ \item{FUN}{Function to be computed over the blocks}
+ \item{which}{Which (if several) of the "best" solutions should be used}
+ \item{\dots}{Further arguments to \code{fun.by.blocks.default} }
+
+}
+
+\value{
+ A numerical matrix of \code{FUN} values by blocks, induced by a partition \code{clu}
+}
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2006): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+}
+
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{opt.random.par}}, \code{\link{opt.these.par}}}
+
+\examples{
+n<-8 #if larger, the number of partitions increases dramaticaly,
+ #as does if we increase the number of clusters
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(3,5))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+#we select a random parition and then optimise it
+
+all.par<-nkpartitions(n=n, k=length(tclu)) #forming the partitions
+all.par<-lapply(apply(all.par,1,list),function(x)x[[1]])
+# to make a list out of the matrix
+
+#optimizing 10 random partitions with opt.these.par
+res<-opt.these.par(M=net,
+ partitions=all.par[sample(1:length(all.par),size=10)],
+ approach="ss", blocks="com")
+plot(res) #Hopefully we get the original partition
+fun.by.blocks(res)
+#computing mean by blocks, ignoring the diagonal (default)
+res$best[[1]]$BM
+#the same result computed by opt.these.par when
+#approach="ss" and blocks="com"
+}
+\keyword{ cluster }% at least one, from doc/KEYWORDS
+\keyword{ math }% at least one, from doc/KEYWORDS
diff --git a/man/genRandomPar.Rd b/man/genRandomPar.Rd
new file mode 100644
index 0000000..f47ccf8
--- /dev/null
+++ b/man/genRandomPar.Rd
@@ -0,0 +1,32 @@
+\name{genRandomPar}
+\alias{genRandomPar}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{The function for generating random partitions}
+\description{
+ The function generates random partitions. The function is meant to be caled by the function \code{\link{opt.random.par}}
+}
+\usage{
+genRandomPar(k, n, seed = NULL, mingr = 1, maxgr = Inf,
+ addParam = list(genPajekPar = TRUE, probGenMech = NULL))
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{k}{Number of clusters (by modes)}
+ \item{n}{Number of units (by modes)}
+ \item{seed}{Seed for generating random numbers (partitions)}
+ \item{mingr}{Minimal alowed group size}
+ \item{maxgr}{Maximal alowed group size}
+ \item{addParam}{This has to be a list with the following parameters (any or all can be missing, then the default values (see usage) are used):\cr
+ "genPajekPar" - Should the partitions be generated as in Pajek (Batagelj and Mrvar, 2006). If \code{FALSE}, all partitions are selected completly at random while making sure that the partitions have the required number of clusters. \cr
+ "probGenMech" - Here the probabilities for 4 diferent generating mechanichems can be specified. If this is not specified, the value is set to \code{c(1/3,1/3,1/3,0)} if \code{genPajekPar} is \code{TRUE} and to \code{c(0,0,0,1)} if \code{genPajekPar} is \code{FALSE}. The first 3 mechanisems are the same as implemetned in Pajek (the second one has almost all units in only one cluster) and the fourth is completly random (from uniform distribution).
+}
+}
+\value{
+ A random partition in the format required by \code{\link{opt.random.par}}. If a netowork has several modes, than a list of partitions, one for each mode.
+}
+\references{
+BATAGELJ, Vladimir, MRVAR, Andrej (2006): Pajek 1.11, \url{http://vlado.fmf.uni lj.si/pub/networks/pajek/} (accessed January 6, 2006).
+}
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{opt.random.par}}}
+\keyword{cluster}
diff --git a/man/gplot1.Rd b/man/gplot1.Rd
new file mode 100644
index 0000000..fda64c6
--- /dev/null
+++ b/man/gplot1.Rd
@@ -0,0 +1,44 @@
+\name{gplot1}
+\alias{gplot1}
+\alias{gplot2}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{A wrapper for funcction gplot - Two-Dimensional Visualization of Graphs}
+\description{
+The function calls function \code{gplot} from library sna with different defaults. Usefun for ploting image graphs.
+}
+\usage{
+gplot1(M, diag = TRUE, displaylabels = TRUE, boxed.labels = FALSE,
+ loop.cex = 4, arrowhead.cex = NULL, arrowheads.fun = "sqrt",
+ edge.lwd = 1, edge.col = "default", rel.thresh = 0.05, ...)
+gplot2(M, uselen = TRUE, usecurve = TRUE, edge.len = 0.001,
+ diag = TRUE, displaylabels = TRUE, boxed.labels = FALSE,
+ loop.cex = 4, arrowhead.cex = 2.5, edge.lwd = 1,
+ edge.col = "default", rel.thresh = 0.05, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{A matix (array) of a graph or set thereof. This data may be valued. }
+ \item{diag}{ boolean indicating whether or not the diagonal should be treated as valid data. Set this true if and only if the data can contain loops. \code{diag} is \code{FALSE} by default. }
+ \item{rel.thresh}{ real number indicating the lower relative (compared to the highest value) threshold for tie values. Only ties of value >\code{thresh} are displayed. By default, \code{thresh}=0.}
+ \item{displaylabels}{ boolean; should vertex labels be displayed? }
+ \item{boxed.labels}{ boolean; place vertex labels within boxes? }
+ \item{arrowhead.cex}{An expansion factor for edge arrowheads.}
+ \item{arrowheads.fun}{A function for scaling arrowheands.}
+ \item{loop.cex}{ expansion factor for loops; may be given as a vector, if loops are to be of different sizes. }
+ \item{edge.col}{ color for edges; may be given as a vector or adjacency matrix, if edges are to be of different colors. }
+ \item{edge.lwd}{ line width scale for edges; if set greater than 0, edge widths are scaled by \code{edge.lwd*dat}. May be given as a vector or adjacency matrix, if edges are to have different line widths. }
+ \item{edge.len}{ if \code{uselen==TRUE}, curved edge lengths are scaled by \code{edge.len}. }
+ \item{uselen}{ boolean; should we use \code{edge.len} to rescale edge lengths? }
+ \item{usecurve}{ boolean; should we use \code{edge.curve}? }
+ \item{\dots}{ additional arguments to \code{\link{plot}} or \code{gplot} from package \code{sna}:\cr\cr
+ \bold{\code{mode}}: the vertex placement algorithm; this must correspond to a \code{gplot.layout} function from package \code{sna}.
+ }
+}
+
+\value{
+ Plots a graph
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{sna:gplot}}
+\keyword{graphs}% at least one, from doc/KEYWORDS
diff --git a/man/ircNorm.Rd b/man/ircNorm.Rd
new file mode 100644
index 0000000..031bcc5
--- /dev/null
+++ b/man/ircNorm.Rd
@@ -0,0 +1,34 @@
+\name{ircNorm}
+\alias{ircNorm}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Function for iterated row and column normalization of valued matrices.}
+\description{
+ The aim is to obtain a matrix with row and column sums equal to 1. This is achieved by iterating row and column normalization. This is usually not possible if any row or column has only 1 non-zero cell.
+}
+\usage{
+ircNorm(M, eps = 10^-12, maxiter = 1000)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{A non-negative valued matrix to be normalized}
+ \item{eps}{The maximum allows squared deviation of a row or column maximum from 1 (if not exaclty 0). Also, if the all deviations in to consequtive iterations are smaller, the process is termianted.}
+ \item{maxiter}{Maximum number of iterations. If reached the process is termianted and the current solution returned}
+}
+\value{
+ Normalized matrix.
+}
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\examples{
+
+A<-matrix(runif(100),ncol=10)
+A #A non-normalized matrix with different row and column sums.
+apply(A,1,sum)
+apply(A,2,sum)
+A.norm<-ircNorm(A)
+A.norm #Normalized matrix with all row and column sums aproximately 1.
+apply(A.norm,1,sum)
+apply(A.norm,2,sum)
+}
+
+\keyword{manip}
+
diff --git a/man/nkpartitions.Rd b/man/nkpartitions.Rd
new file mode 100644
index 0000000..4752278
--- /dev/null
+++ b/man/nkpartitions.Rd
@@ -0,0 +1,44 @@
+\name{nkpartitions}
+\alias{nkpartitions}
+\alias{nkpar}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Functions for listing all possible partitions or just cunting the number of them.}
+\description{
+The function \code{nkpartitions} lists all possible partitions of n objects in to k clusters. The function \code{nkpar} only gives the number of such partitions.
+}
+\usage{
+nkpartitions(n, k, exact = TRUE, print = FALSE)
+nkpar(n, k)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{n}{Number of units/objects}
+ \item{k}{Number of clusters/groups}
+ \item{exact}{Search for partitions with exactly k or at most k clusters}
+ \item{print}{print results as they are found?}
+}
+\value{
+The matrix or number of possible partitions.
+}
+\author{Chris Andrews}
+\examples{
+n<-8 #if larger, the number of partitions increases dramaticaly,
+ #as does if we increase the number of clusters
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(3,5))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+#computation of criterion function with the correct partition
+nkpar(n=n, k=length(tclu)) #computing the number of partitions
+all.par<-nkpartitions(n=n, k=length(tclu)) #forming the partitions
+all.par<-lapply(apply(all.par,1,list),function(x)x[[1]])
+# to make a list out of the matrix
+res<-check.these.par(M=net,partitions=all.par,approach="ss",blocks="com")
+plot(res) #we get the original partition
+}
+\keyword{cluster}% at least one, from doc/KEYWORDS
+
diff --git a/man/opt.par.Rd b/man/opt.par.Rd
new file mode 100644
index 0000000..89e0937
--- /dev/null
+++ b/man/opt.par.Rd
@@ -0,0 +1,93 @@
+\name{opt.par}
+\alias{opt.par}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Optimizes a partition based on the value of a criterion function.}
+\description{
+The function optimizes a partition based on the value of a criterion function (see \code{\link{crit.fun}}) for a given network and blockmodel for Generalized blockmodeling (Žiberna, 2006) based on other parameters (see below).
+The optimization is done through local optimization, where the neighbourhood of a partition includes all partitions that can be obtained by moving one unit from one cluster to another or by exchanging two units (from different clusters).
+}
+\usage{
+opt.par(M, clu, approach, ..., maxiter = 50, trace.iter =
+ FALSE, switch.names = NULL, save.initial.param = TRUE,
+ skip.par = NULL, save.checked.par =
+ !is.null(skip.par), merge.save.skip.par =
+ all(!is.null(skip.par), save.checked.par), check.skip
+ = "never")
+}
+
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network can have one or more modes (diferent kinds of units with no ties among themselvs. If the network is not two-mode, the matrix must be square.}
+ \item{clu}{A partition. Each unique value represents one cluster. If the nework is one-mode, than this should be a vector, else a list of vectors, one for each mode}
+ \item{maxiter}{Maxsimum number of iterations allowed}
+ \item{approach}{One of the approaches described in Žiberna (2006). Possible values are:\cr
+ "bin" - binary blockmodeling,\cr
+ "val" - valued blockmodeling,\cr
+ "imp" - implicit blockmodeling,\cr
+ "ss" - sum of squares homogenity blockmodeling, and\cr
+ "ad" - absolute deviations homogenity blockmodeling.}
+ \item{\dots}{Argumets passed to other functions, see \code{\link{crit.fun}} and arguments to function \code{gen.crit.fun} (as this function is not intented to be called directly, it also has no help files). Some might be obligatory, e.g. argument \code{m} when using Valued blockmodeling approach.Therefore these arguments are described below:\cr\cr
+ \bold{\code{use.for.opt}}: Should FORTRAN function be used for optimization if possible. If FORTRAN function is used, the speed is dramatically increast, however some the output is slightly different and the plotting function might not work. FORTRAN subrutines are available for only very special cases, currently only for using "ss" aproach and only complete blocks. If you are using such setting and some special features (these are not implemented in FORTRAN subrutines - e.g. using fun [...]
+ \bold{\code{use.for}}: (default = \code{TRUE}) Should FORTRAN subrutines be used where available (available for only very special cases, currently only for using "ss" aproach and only complete blocks. If you are using such setting and some special features (these are not implemented in FORTRAN subrutines), it's safer to set it to FASLE, as the fuction may miss that these features are not implemented in FORTRAN subrutines and use them nevertheless, leading to wrong results.\cr\cr
+ \bold{\code{check.switch}}: If \code{TRUE} (the default), the neighborhood of the selected partition also includes the partitions that can be obtained by exchanging (switching) two units from diferent clusters).\cr\cr
+ \bold{\code{check.all}}: If \code{TRUE} (the default), all partitions in the neighborhood of the selected partition are first evaluated and the current partition than changes to the one with the lowest value of the criterion function (if lower than that of the current partition). If \code{FALSE}, the first partition with the criterion lower the current partition becomes the new current partition (and the iteration terminates).\cr\cr
+ }
+ \item{trace.iter}{Should the result of each iteration (and not only of the best one) be saved}
+ \item{switch.names}{Should partitions that differ only in diferent names of positions be treated as different. It should be set to \code{TRUE} only if a asymetric blockmodel via \code{BLOCKS} is specified. The default \code{NULL} tries to find that.}
+ \item{save.initial.param}{Should the inital parameters (\code{approach},...) be saved}
+ \item{skip.par}{The partitions that are not allowed or were already checked and should therfire be skiped.}
+ \item{save.checked.par}{Should the checked partitions be saved. For example, so that they can be used in the next call as \code{skip.par}}
+ \item{merge.save.skip.par}{Should the checked partitions be merged with skiped ones?}
+ \item{check.skip}{When should the check be preformed:\cr
+ "all" - before every call to 'crit.fun'\cr
+ "iter" - at the end of eack iteratiton\cr
+ "never" - never}
+}
+\value{
+ \item{M}{The matrix of the network analyzed}
+ \item{best}{A list of results from \code{crit.fun.tmp} with the same elements as the result of \code{crit.fun}, only without \code{M}}
+ \item{iter}{A list of resoults the same as \code{best} - one \code{best} for each iteration}
+ \item{err}{If selected - The vector of errors or inconsistencies of the emplirical network with the ideal network for a given blockmodel (model,approach,...) and parititions}
+ \item{nIter}{The number of iterations used. It can show that \code{maxiter} is to low if this value is equal to \code{maxiter}}
+ \item{call}{The call used to call the function.}
+ \item{initial.param}{If selected - The inital parameters used.}
+ \item{checked.par}{If selected - A list of checked parititions. If \code{merge.save.skip.par} is \code{TRUE}, this list also includs the partitions in \code{skip.par}.}
+ ...
+}
+\section{Warning }{
+This function can be extremly slow. The time complexity is incrising with the number od units and the number of clusters. It is advaisable to firtst time the function on a smaller network.
+}
+
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2006): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+
+DOREIAN, Patrick, BATAGELJ, Vladimir, FERLIGOJ, \enc{Anuška}{Anuska} (2005): Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press, 2005. XV, 384 p., ISBN 0-521-84085-6.
+}
+
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{crit.fun}}, \code{\link{check.these.par}}, \code{\link{opt.random.par}}, \code{\link{opt.these.par}}, \code{\link{plot.opt.par}}}
+\examples{
+n<-8 #if larger, the number of partitions increases dramaticaly,
+ #as does if we increase the number of clusters
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(3,5))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+#we select a random parition and then optimise it
+
+all.par<-nkpartitions(n=n, k=length(tclu)) #forming the partitions
+all.par<-lapply(apply(all.par,1,list),function(x)x[[1]])
+# to make a list out of the matrix
+res<-opt.par(M=net,
+ clu=all.par[[sample(1:length(all.par),size=1)]],
+ approach="ss",blocks="com")
+plot(res) #Hopefully we get the original partition
+}
+\keyword{cluster}% at least one, from doc/KEYWORDS
+\keyword{graphs}% at least one, from doc/KEYWORDS
diff --git a/man/opt.random.par.Rd b/man/opt.random.par.Rd
new file mode 100644
index 0000000..cfda767
--- /dev/null
+++ b/man/opt.random.par.Rd
@@ -0,0 +1,136 @@
+\name{opt.random.par}
+\alias{opt.random.par}
+\alias{opt.these.par}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Optimizes a set of partitions based on the value of a criterion function.}
+\description{
+The function optimizes a set partitions based on the value of a criterion function (see \code{\link{crit.fun}} for details on the criterion function) for a given network and blockmodel for Generalized blockmodeling (Žiberna, 2006) based on other parameters (see below).
+The optimization is done through local optimization, where the neighborhood of a partition includes all partitions that can be obtained by moving one unit from one cluster to another or by exchanging two units (from different clusters).
+A list of paritions can be specified (\code{opt.these.par}) or the number of clusters and a number of partitions to generate (\code{opt.random.par}).
+}\usage{
+ opt.random.par(M, k, n = NULL, rep, approach, ..., return.all =
+ FALSE, return.err = TRUE, maxiter = 50, trace.iter =
+ FALSE, switch.names = NULL, save.initial.param = TRUE,
+ skip.par = NULL, save.checked.par = TRUE,
+ merge.save.skip.par = any(!is.null(skip.par),
+ save.checked.par), skip.allready.checked.par = TRUE,
+ check.skip = "iter", print.iter = FALSE, max.iden =
+ 10, seed = NULL, parGenFun = genRandomPar, mingr = 1,
+ maxgr = Inf, addParam = list(genPajekPar = TRUE,
+ probGenMech = NULL), maxTriesToFindNewPar = rep * 10)
+
+opt.these.par(M, partitions, approach, ..., return.all = FALSE,
+ return.err = TRUE, skip.allready.checked.par = TRUE,
+ maxiter = 50, trace.iter = FALSE, switch.names = NULL,
+ save.initial.param = TRUE, skip.par = NULL,
+ save.checked.par = !is.null(skip.par),
+ merge.save.skip.par = all(!is.null(skip.par),
+ save.checked.par), check.skip = "never", print.iter =
+ FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network can have one or more modes (diferent kinds of units with no ties among themselvs. If the network is not two-mode, the matrix must be square.}
+ \item{k}{The number of clustrs used in generation of partitions.}
+ \item{n}{The vector of the number of units in each mode (only necessary if mode is larger than 2.}
+ \item{rep}{The number of repetitions/different starting partitions to check.}
+ \item{partitions}{A list of partitions. Each unique value represents one cluster. If the nework is one-mode, than this should be a vector, else a list of vectors, one for each mode.}
+ \item{approach}{One of the approaches described in Žiberna (2007). Possible values are:\cr
+ "bin" - binary blockmodeling,\cr
+ "val" - valued blockmodeling,\cr
+ "imp" - implicit blockmodeling,\cr
+ "ss" - sum of squares homogenity blockmodeling, and\cr
+ "ad" - absolute deviations homogenity blockmodeling.}
+ \item{\dots}{Argumets passed to other functions, see \code{\link{crit.fun}} and arguments to function \code{gen.crit.fun} (as this function is not intented to be called directly, it also has no help files). Some might be obligatory, e.g. argument \code{m} when using Valued blockmodeling approach.Therefore these arguments are described below:\cr\cr
+ \bold{\code{use.for.opt}}: Should FORTRAN function be used for optimization if possible. If FORTRAN function is used, the speed is dramatically increast, however some the output is slightly different and the plotting function might not work. FORTRAN subrutines are available for only very special cases, currently only for using "ss" aproach and only complete blocks. If you are using such setting and some special features (these are not implemented in FORTRAN subrutines - e.g. using fun [...]
+ \bold{\code{use.for}}: (default = \code{TRUE}) Should FORTRAN subrutines be used where available (available for only very special cases, currently only for using "ss" aproach and only complete blocks. If you are using such setting and some special features (these are not implemented in FORTRAN subrutines), it's safer to set it to FASLE, as the fuction may miss that these features are not implemented in FORTRAN subrutines and use them nevertheless, leading to wrong results.\cr\cr
+ \bold{\code{check.switch}}: If \code{TRUE} (the default), the neighborhood of the selected partition also includes the partitions that can be obtained by exchanging (switching) two units from diferent clusters).\cr\cr
+ \bold{\code{check.all}}: If \code{TRUE} (the default), all partitions in the neighborhood of the selected partition are first evaluated and the current partition than changes to the one with the lowest value of the criterion function (if lower than that of the current partition). If \code{FALSE}, the first partition with the criterion lower the current partition becomes the new current partition (and the iteration terminates).\cr\cr
+ }
+ \item{return.all}{If \code{FALSE}, solution for only the best (one or more) partition/s is/are returned.}
+ \item{return.err}{Should the error for each optimized partition be returned}
+ \item{maxiter}{Maximum number of iterations}
+ \item{trace.iter}{Should the result of each iteration (and not only of the best one) be saved}
+ \item{switch.names}{Should partitions that differ only in diferent names of positions be treated as different. It should be set to \code{TRUE} only if a asymetric blockmodel via \code{BLOCKS} is specified.}
+ \item{save.initial.param}{Should the inital parameters (\code{approach},...) be saved}
+ \item{skip.par}{The partitions that are not allowed or were already checked and should therfire be skiped.}
+ \item{save.checked.par}{Should the checked partitions be saved. For example, so that they can be used in the next call as \code{skip.par}}
+ \item{merge.save.skip.par}{Should the checked partitions be merged with skiped ones?}
+ \item{skip.allready.checked.par}{If \code{TRUE},the partitions that were already checked when runing \code{opt.par} form different statrting points will be skiped.}
+ \item{check.skip}{When should the check be preformed:\cr
+ "all" - before every call to 'crit.fun' (Time demanding)\cr
+ "iter" - at the end of eack iteratiton\cr
+ "opt.par" - before every call to \code{opt.par}, when starting the optimization of a new partition.\cr
+ "never" - never}
+ \item{print.iter}{Should the progress of each iteration be printed?}
+ \item{max.iden}{The maximum number of results that should be saved (in case there are more than max.iden results with minimal error, only the first max.iden will be saved).}
+ \item{seed}{Optional. The seed for random generation of partitions.}
+ \item{parGenFun}{The fucntion (object) that will generate rendom partitions. The deault fuction is \code{\link{genRandomPar}}. The function has to accept the following parameters: k (number of partitions by modes, n (number of units by modes), seed (seed value for random generation of partition), addParam (a list of additional parametres)}
+ \item{mingr}{Minimal alowed group size}
+ \item{maxgr}{Maximal alowed group size}
+ \item{addParam}{A list of additional parameters for function specified above. In the usage section they are specified for the dthe default function \code{\link{genRandomPar}}:}
+ \item{maxTriesToFindNewPar}{The maximum number of partition try when trying to find a new partition to optimize that was not yet checked before - the default value is \code{rep*1000}}
+}
+
+\value{
+ \item{M}{The matrix of the network analyzed}
+ \item{res}{If \code{return.all = TRUE} - A list of results the same as \code{best} - one \code{best} for each partition optimized}
+ \item{best}{A list of results from \code{crit.fun.tmp} with the same elements as the result of \code{crit.fun}, only without \code{M}}
+ \item{err}{If \code{return.err = TRUE} - The vector of errors or inconsistencies of the emplirical network with the ideal network for a given blockmodel (model,approach,...) and parititions}
+ \item{nIter}{The vector of number of iterations used - one value for each starting partition that was optimized. It can show that \code{maxiter} is to low if a lot of these values have the value of \code{maxiter}}
+ \item{checked.par}{If selected - A list of checked parititions. If \code{merge.save.skip.par} is \code{TRUE}, this list also includs the partitions in \code{skip.par}.}
+ \item{call}{The call used to call the function.}
+ \item{initial.param}{If selected - The inital parameters used.}
+}
+\section{Warning }{
+This function can be extremly slow. The time complexity is incrising with the number od units and the number of clusters. It is advaisable to firtst time the function on a smaller network.
+}
+
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2007): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+
+DOREIAN, Patrick, BATAGELJ, Vladimir, FERLIGOJ, \enc{Anuška}{Anuska} (2005): Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press, 2005. XV, 384 p., ISBN 0-521-84085-6.
+
+BATAGELJ, Vladimir, MRVAR, Andrej (2006): Pajek 1.11, \url{http://vlado.fmf.uni lj.si/pub/networks/pajek/} (accessed January 6, 2006).
+}
+
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{crit.fun}}, \code{\link{check.these.par}}, \code{\link{opt.par}}, \code{\link{plot.opt.more.par}}}
+\examples{
+n<-8 #if larger, the number of partitions increases dramaticaly,
+ #as does if we increase the number of clusters
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(3,5))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+#we select a random parition and then optimise it
+
+all.par<-nkpartitions(n=n, k=length(tclu))
+#forming the partitions
+all.par<-lapply(apply(all.par,1,list),function(x)x[[1]])
+# to make a list out of the matrix
+
+#optimizing one partition
+res<-opt.par(M=net,
+ clu=all.par[[sample(1:length(all.par),size=1)]],
+ approach="ss",blocks="com")
+plot(res) #Hopefully we get the original partition
+
+#optimizing 10 random chosen partitions with opt.these.par
+res<-opt.these.par(M=net,
+ partitions=all.par[sample(1:length(all.par),size=10)],
+ approach="ss", blocks="com")
+plot(res) #Hopefully we get the original partition
+
+#optimizing 10 random chosen partitions with opt.random.par
+res<-opt.random.par(M=net,k=2,rep=10,approach="ss",blocks="com")
+plot(res) #Hopefully we get the original partition
+}
+\keyword{cluster}% at least one, from doc/KEYWORDS
+\keyword{graphs}% at least one, from doc/KEYWORDS
diff --git a/man/plot.mat.Rd b/man/plot.mat.Rd
new file mode 100644
index 0000000..25fb359
--- /dev/null
+++ b/man/plot.mat.Rd
@@ -0,0 +1,167 @@
+\name{plot.mat}
+\alias{plot.mat}
+\alias{plot.mat.nm}
+\alias{plot.crit.fun}
+\alias{plot.opt.par}
+\alias{plot.opt.par.mode}
+\alias{plot.opt.more.par}
+\alias{plot.opt.more.par.mode}
+\alias{plot.check.these.par}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Functions for plotting a partitioned matrix}
+\description{
+The main function \code{plot.mat} plots a (optionally partitioned) matrix. If the matrix is partitioned, the rows and columns of the matrix are rearranged according to the partitions. Other functions are only wrappers for \code{plot.mat} for convenience when plotting the results of the corresponding functions. The \code{plot.mat.nm} plots two matrices based on M, normalized by rows and columns, next to each other.
+}
+\usage{
+plot.mat(x=M, M=x, clu = NULL, ylab = "", xlab = "", main = NULL,
+ print.val = !length(table(M)) <= 2, print.0 = FALSE,
+ plot.legend = !print.val && !length(table(M)) <= 2,
+ print.legend.val = "out", print.digits.legend = 2,
+ print.digits.cells = 2, print.cells.mf = NULL,
+ outer.title = !plot.legend,
+ title.line = ifelse(outer.title, -1.5, 7),
+ mar = c(0.5, 7, 8.5, 0) + 0.1, cex.val = "default",
+ val.y.coor.cor = 0, val.x.coor.cor = 0, cex.legend = 1,
+ legend.title = "Legend", cex.axes = "default",
+ print.axes.val = NULL,
+ print.x.axis.val = !is.null(colnames(M)),
+ print.y.axis.val = !is.null(rownames(M)),
+ x.axis.val.pos = 1.1, y.axis.val.pos = -0.1,
+ cex.main = par()$cex.main, cex.lab = par()$cex.lab,
+ yaxis.line = -1.5, xaxis.line = -1, legend.left = 0.4,
+ legend.up = 0.03, legend.size = 1/min(dim(M)),
+ legend.text.hor.pos = 0.5, par.line.width = 3,
+ par.line.col = "blue", IM.dens = NULL, IM = NULL, wnet = 1,
+ wIM = NULL,
+ use.IM = length(dim(IM))==length(dim(M))|!is.null(wIM),
+ dens.leg = c(null = 100),
+ blackdens = 70, plotLines = TRUE, ...)
+
+plot.mat.nm(x=M, M=x, ..., main.title = NULL,
+ title.row = "Row normalized",
+ title.col = "Column normalized",
+ main.title.line = -2, par.set = list(mfrow = c(1, 2)))
+
+\method{plot}{mat}(x=M, M=x, clu = NULL, ylab = "", xlab = "",
+ main = NULL, print.val = !length(table(M)) <= 2,
+ print.0 = FALSE,
+ plot.legend = !print.val && !length(table(M)) <= 2,
+ print.legend.val = "out", print.digits.legend = 2,
+ print.digits.cells = 2, print.cells.mf = NULL,
+ outer.title = !plot.legend,
+ title.line = ifelse(outer.title, -1.5, 7),
+ mar = c(0.5, 7, 8.5, 0) + 0.1, cex.val = "default",
+ val.y.coor.cor = 0, val.x.coor.cor = 0, cex.legend = 1,
+ legend.title = "Legend", cex.axes = "default",
+ print.axes.val = NULL,
+ print.x.axis.val = !is.null(colnames(M)),
+ print.y.axis.val = !is.null(rownames(M)),
+ x.axis.val.pos = 1.1, y.axis.val.pos = -0.1,
+ cex.main = par()$cex.main, cex.lab = par()$cex.lab,
+ yaxis.line = -1.5, xaxis.line = -1, legend.left = 0.4,
+ legend.up = 0.03, legend.size = 1/min(dim(M)),
+ legend.text.hor.pos = 0.5, par.line.width = 3,
+ par.line.col = "blue", IM.dens = NULL, IM = NULL, wnet = 1,
+ wIM = NULL,
+ use.IM = length(dim(IM)) == length(dim(M)) | !is.null(wIM),
+ dens.leg = c(null = 100), blackdens = 70, plotLines = TRUE,
+ ...)
+
+\method{plot}{crit.fun}(x, main = NULL, ...)
+
+\method{plot}{opt.par}(x, main = NULL, which = 1, ...)
+
+\method{plot}{opt.par.mode}(x, main = NULL, which = 1, ...)
+
+\method{plot}{opt.more.par}(x, main = NULL, which = 1, ...)
+
+\method{plot}{opt.more.par.mode}(x, main = NULL, which = 1, ...)
+
+\method{plot}{check.these.par}(x, main = NULL, which = 1, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{A result from a corespodning function or a matrix or similar object representing a network}
+ \item{M}{A matrix or similar object representing a network - either x or M must be supplied - both are here to make the code compatible with generic and with older functions}
+ \item{clu}{A partition}
+ \item{ylab}{Label for y axis}
+ \item{xlab}{Label for x axis}
+ \item{main}{Main title}
+ \item{main.title}{Main title in nm version}
+ \item{main.title.line}{The line in which main title is printed in nm version}
+ \item{title.row}{Title for the row-normalized matrix in nm version}
+ \item{title.col}{Title for the column-normalized matrix in nm version}
+ \item{par.set}{A list of possible ploting paramters (to \code{par}) to be used in nm version}
+ \item{print.val}{Should the values be printed in the matrix}
+ \item{print.0}{If \code{print.val=TRUE} Should the 0s be printed in the matrix}
+ \item{plot.legend}{Should the legend for shades be ploted}
+ \item{print.legend.val}{Should the values be printed in the legend}
+ \item{print.digits.legend}{The number of digits that should appear in the legend}
+ \item{print.digits.cells}{The number of digits that should appear in the cells (of the matrix and/or legend)}
+ \item{print.cells.mf}{if not \code{NULL}, the above argument is igonred, the cell values are printed as the cell are multiplied by this factor and rounded}
+ \item{outer.title}{Should the title be printed on the 'inner' or 'outer' plot, default is 'inner' if legend is ploted and 'outer' otherwise. May be soon omited.}
+ \item{title.line}{The line (from the top) where the title should be printed. The suitable values depend heavily on the displey type.}
+ \item{mar}{A numerical vector of the form 'c(bottom, left, top, right)' which gives the lines of margin to be specified on the four sides of the plot. The R default for ordianry plots is 'c(5, 4, 4, 2) + 0.1', while this functions default is c(0.5, 7, 8.5, 0) + 0.1.}
+ \item{cex.val}{Size of the values printed. The "default" is 10/"number of units"}
+ \item{val.y.coor.cor}{Correction for centering the values in the sqares in y direction}
+ \item{val.x.coor.cor}{Correction for centering the values in the sqares in x direction}
+ \item{cex.legend}{Size of the text in the legend}
+ \item{legend.title}{The title of the legend}
+ \item{cex.axes}{Size of the characters in axes, 'default' makes the cex so small that all categories can be printed}
+ \item{print.axes.val}{Should the axes values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL'}
+ \item{print.x.axis.val}{Should the x axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL'}
+ \item{print.y.axis.val}{Should the y axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL'}
+ \item{x.axis.val.pos}{x coordiante of the y axis values}
+ \item{y.axis.val.pos}{y coordiante of the x axis values}
+ \item{cex.main}{Size of the text in the main title}
+ \item{cex.lab}{Size of the text in matrix}
+ \item{yaxis.line}{The position of the y axis (the argument 'line')}
+ \item{xaxis.line}{The position of the x axis (the argument 'line')}
+ \item{legend.left}{How much left should the legend be from the matrix}
+ \item{legend.up}{How much up should the legend be from the matrix}
+ \item{legend.size}{Relative legend size}
+ \item{legend.text.hor.pos}{Horizontal position of the legend text (bottom) - 0 = bottom, 0.5 = middle,...}
+ \item{par.line.width}{The width of the line that seperates the partitions}
+ \item{par.line.col}{The color of the line that seperates the partitions}
+ \item{IM.dens}{The densitiey of shading lines for each block}
+ \item{IM}{The image (as obtaind with \code{crit.fun}) of the blockmodel. \code{dens.leg} is used to translate this image into \code{IM.dens}.}
+ \item{dens.leg}{It is used to translate the \code{IM} into \code{IM.dens}.}
+ \item{blackdens}{At which density should the values on dark colurs of lines be printed in white.}
+ \item{plotLines}{Should the lines in the matrix be printed - default TRUE, best set to FALSE for larger networks.}
+ \item{which}{Which (if there are more than one) of optimal solutions to plot}
+ \item{wnet}{Specifies which net (if more) should be ploted - used if M is an array.}
+ \item{wIM}{Specifies which IM (if more) should be used for ploting (defualt = wnet) - used if IM is an array.}
+ \item{use.IM}{Specifies if IM should IM be used for ploting? be used for ploting?}
+ \item{\dots}{Aditional arguments to \code{plot.default} for \code{plot.mat} and also to \code{plot.mat} for other functions}
+}
+\value{
+ The functions are used for their side affect - plotting.
+}
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2006): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+}
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{crit.fun}}, \code{\link{opt.par}}, \code{\link{opt.random.par}}, \code{\link{opt.these.par}}, \code{\link{check.these.par}}}
+\examples{
+#Generation of the network
+n<-20
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(5,15))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+#Ploting the network
+plot.mat(M=net, clu=clu)
+class(net)<-"mat"
+plot(net, clu=clu)
+#See corespodning functions for examples for other plotting
+#functions
+#presented, that are esentially only the wrappers for "plot.max"
+}
+\keyword{graphs}% at least one, from doc/KEYWORDS
+\keyword{hplot}% at least one, from doc/KEYWORDS
diff --git a/man/rand.Rd b/man/rand.Rd
new file mode 100644
index 0000000..94ad596
--- /dev/null
+++ b/man/rand.Rd
@@ -0,0 +1,27 @@
+\name{rand}
+\alias{crand}
+\alias{crand2}
+\alias{rand}
+\alias{rand2}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Comparing partitions}
+\description{
+Rand Index and Rand Index corrected/adjusted for chance for comparing partitions (Hubert and Arabie, 1985). The names of the clusters do not matter.
+}
+\usage{
+rand(tab)
+rand2(clu1, clu2)
+crand(tab)
+crand2(clu1, clu2)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{clu1, clu2}{The two partitions to be compared, given in the from of vectors, where for each unit a cluster membership is given.}
+ \item{tab}{A contingency table obtaind as table(clu1,clu2)}
+}
+\value{
+ The value of Rand Index (corrected/adjusted for chance)
+}
+\references{Hubert L. in Arabie P. (1985): Comparing Partitions. Journal of Classification, 2, 193-218.}
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\keyword{cluster}% at least one, from doc/KEYWORDS
diff --git a/man/recode.Rd b/man/recode.Rd
new file mode 100644
index 0000000..596d1cc
--- /dev/null
+++ b/man/recode.Rd
@@ -0,0 +1,28 @@
+\name{recode}
+\alias{recode}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Recode}
+\description{
+ Recodes values in a vector.
+}
+\usage{
+recode(x, oldcode = sort(unique(x)), newcode)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{A vector}
+ \item{oldcode}{A vector of old codes}
+ \item{newcode}{A vector of new codes}
+}
+
+\value{
+ A recoded vector
+}
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\examples{
+x<-rep(1:3,times=1:3)
+newx<-recode(x,oldcode=1:3,newcode=c("a","b","c"))
+}
+
+\keyword{ manip }% at least one, from doc/KEYWORDS
+
diff --git a/man/reorderImage.Rd b/man/reorderImage.Rd
new file mode 100644
index 0000000..4882df6
--- /dev/null
+++ b/man/reorderImage.Rd
@@ -0,0 +1,32 @@
+\name{reorderImage}
+\alias{reorderImage}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Reorders an image matrix of the blockmodel (or an error matrix based on new and old partition.}
+\description{
+Reorders an image matrix of the blockmodel (or an error matrix based on new and old partition. The partitions should be the same, except that classes can have different labels. It is useful when we want to have a different oreder of classes in figures and then also in image matrices. Currently it is only suitable for one-mode blockmodels
+}
+\usage{
+reorderImage(IM, oldClu, newClu)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{IM}{An image or error matrix.}
+ \item{oldClu}{Old partition}
+ \item{newClu}{New partition, the same as the old one except for class labeles.}
+}
+%\details{
+% ~~ If necessary, more details than the description above ~~
+%}
+\value{
+ Reorder matrix (rows and columns are reordred)
+}
+\references{
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales} (2006): Generalized Blockmodeling of Valued Networks. Social Networks, Jan. 2007, vol. 29, no. 1, 105-126. \url{http://dx.doi.org/10.1016/j.socnet.2006.04.002}.
+
+\enc{ŽIBERNA, Aleš}{ZIBERNA, Ales}. Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. J. math. sociol., 2008, vol. 32, no. 1, 57-84. \url{http://www.informaworld.com/smpp/content?content=10.1080/00222500701790207}.
+}
+\author{Ales Ziberna}
+\seealso{\code{\link{crit.fun}}, \code{\link{plot.mat}}, \code{\link{clu}}, \code{\link{IM}}, \code{\link{err}}}
+%\examples{
+%}
+\keyword{manip}% at least one, from doc/KEYWORDS
diff --git a/man/sedist.Rd b/man/sedist.Rd
new file mode 100644
index 0000000..b667f3d
--- /dev/null
+++ b/man/sedist.Rd
@@ -0,0 +1,59 @@
+\name{sedist}
+\alias{sedist}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Computes distances in terms of Structural equivalence (Lorrain and White, 1971)}
+\description{
+The functions computed the distances in terms of Structural equivalence (Lorrain and White, 1971) between the units of a one-mode network. Several options for treating the diagonal values are supported.
+}
+\usage{
+sedist(M, method = "default", fun = "default",
+ fun.on.rows = "default", handle.interaction = "switch",
+ use = "pairwise.complete.obs", ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network must be one-mode.}
+ \item{method}{The method used to compute distances - any of the methods alloed by functions dist, cor or cov (all package::stats) or just "cor" or "cov" (given as character).}
+ \item{fun}{Which function should be used to comput distacnes (given as character), .}
+ \item{fun.on.rows}{For non-standard function - does the function compute measure on rows (such as \code{cor}, \code{cov},...) of the data matrix (as opposed to computing measure on columns (such as \code{dist}).}
+ \item{handle.interaction}{How should the interaction between the vertices analysed be handled:\cr
+ "switch" (the default) - assumes that when comparing units i and j, M[i,i] should be compared with M[j,j] and M[i,j] with M[j,i]\cr
+ "ignore" (diagonal) - Diagonal is ignored\cr
+ "none" - the matrix is used "as is"}
+ \item{use}{For use with methods "cor" and "cov", for other methods (the default option should be used if handle.interaction=="ignore"), "pairwise.complete.obs" are always used, if stats.dist.cor.cov=TRUE}
+ \item{\dots}{Additional arguments to \code{fun}}
+}
+\details{
+If both \code{method} and \code{fun} are "default", the euclidian distances are computed. the "default" method for \code{fun="dist"} is "eucludian" and for \code{fun="cor"} "pearson".
+}
+\value{
+ A matrix (usually of class dist) is returned.
+}
+\references{
+Batagelj, V., Ferligoj, A., Doreian, P. (1992): Direct and indirect methods for structural equivalence. Social Networks 14, 63-90.
+
+Lorrain, F., White, H.C., 1971. Structural equivalence of individuals in social networks. Journal of Mathematical Sociology 1, 49-80.
+}
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{dist}}, \code{\link{hclust}}, \code{\link{REGE}}, \code{\link{crit.fun}}, \code{\link{opt.par}}, \code{\link{opt.random.par}}}
+\examples{
+#generating a simple network corresponding to the simple Sum of squares
+#structural equivalence with blockmodel:
+# null com
+# null null
+n<-20
+net<-matrix(NA,ncol=n,nrow=n)
+clu<-rep(1:2,times=c(5,15))
+tclu<-table(clu)
+net[clu==1,clu==1]<-rnorm(n=tclu[1]*tclu[1],mean=0,sd=1)
+net[clu==1,clu==2]<-rnorm(n=tclu[1]*tclu[2],mean=4,sd=1)
+net[clu==2,clu==1]<-rnorm(n=tclu[2]*tclu[1],mean=0,sd=1)
+net[clu==2,clu==2]<-rnorm(n=tclu[2]*tclu[2],mean=0,sd=1)
+
+D<-sedist(M=net)
+plot.mat(net, clu=cutree(hclust(d=D,method="ward"),k=2))
+}
+
+\keyword{cluster}% at least one, from doc/KEYWORDS
+\keyword{graphs}% at least one, from doc/KEYWORDS
+
diff --git a/man/ss.Rd b/man/ss.Rd
new file mode 100644
index 0000000..be51d6d
--- /dev/null
+++ b/man/ss.Rd
@@ -0,0 +1,17 @@
+\name{ss}
+\alias{ss}
+\alias{ad}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Sum of Squared deviations from the mean and sum of Absolute Deviations from the median}
+\description{Functions to compute Sum of Squared deviations from the mean and sum of Absolute Deviations from the median}
+\usage{
+ss(x)
+ad(x)
+}
+\arguments{
+ \item{x}{A numeric vector.}
+}
+\value{
+Sum of Squared deviations from the mean or sum of Absolute Deviations from the median}
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\keyword{univar}% at least one, from doc/KEYWORDS
diff --git a/man/two2one.Rd b/man/two2one.Rd
new file mode 100644
index 0000000..1eddd0a
--- /dev/null
+++ b/man/two2one.Rd
@@ -0,0 +1,54 @@
+\name{two2one}
+\alias{two2one}
+\alias{one2two}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Two-mode network conversions}
+\description{
+ Coverting two mode networks from two to one mode matrix representation and vice versa. If a two-mode matrix is converted in-to a one-mode matrix, the original two-mode matrix lies in the upper right corner of the one-mode matrix.
+}
+\usage{
+two2one(M, clu = NULL)
+one2two(M, clu = NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{M}{A matrix representing the (usually valued) network.}
+ \item{clu}{A partition. Each unique value represents one cluster. This should be a list of two vectors, one for each mode.}
+}
+
+\value{
+Functions returns list with elemets:
+a mode mode matrix with the two mode network in its upper left corner.
+ \item{M}{The matrix}
+ \item{clu}{The partition, in form appropriate for the mode of the matrix}
+
+}
+\author{\enc{Aleš Žiberna}{Ales Ziberna}}
+\seealso{\code{\link{crit.fun}}, \code{\link{opt.par}}, \code{\link{opt.random.par}}, \code{\link{plot.mat}}}
+\examples{
+#generating a simple network corresponding to the simple Sum of squares
+#structural equivalence with blockmodel:
+# null com
+# null null
+n<-c(7,13)
+net<-matrix(NA,nrow=n[1],ncol=n[2])
+clu<-list(rep(1:2,times=c(3,4)),rep(1:2,times=c(5,8)))
+tclu<-lapply(clu,table)
+net[clu[[1]]==1,clu[[2]]==1]<-rnorm(n=tclu[[1]][1]*tclu[[2]][1],
+ mean=0,sd=1)
+net[clu[[1]]==1,clu[[2]]==2]<-rnorm(n=tclu[[1]][1]*tclu[[2]][2],
+ mean=4,sd=1)
+net[clu[[1]]==2,clu[[2]]==1]<-rnorm(n=tclu[[1]][2]*tclu[[2]][1],
+ mean=4,sd=1)
+net[clu[[1]]==2,clu[[2]]==2]<-rnorm(n=tclu[[1]][2]*tclu[[2]][2],
+ mean=0,sd=1)
+plot.mat(net,clu=clu) #two mode matrix of a two mode network
+#converting to one mode network
+M1<-two2one(net)$M
+plot.mat(M1,clu=two2one(net)$clu) #plotting one mode matrix
+plot.mat(one2two(M1,clu=clu)$M,clu=clu)
+#converting one to two mode matix and ploting
+}
+\keyword{cluster}% at least one, from doc/KEYWORDS
+\keyword{graphs}% at least one, from doc/KEYWORDS
+
diff --git a/src/REGD_NE_R.f90 b/src/REGD_NE_R.f90
new file mode 100644
index 0000000..7434d6f
--- /dev/null
+++ b/src/REGD_NE_R.f90
@@ -0,0 +1,117 @@
+! REGDI.FOR 3/18/85 - DOUG WHITE'S REGULAR DISTANCES PROGRAM
+ subroutine regdne(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, CM, Row, Col
+ INTEGER NR, N, ITER, KR, JJ, II
+ DIMENSION DEG (N), SUM (N,N), R (N,N, NR), B (N,N), Row(N), Col(N)
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL DISTANCE
+ DO 100 I=1,N
+ DEG(I)=0.0
+ DO 100 J=1,N
+ SUM(I,J)=0.0
+ DO 50 KR=1,NR
+ SM = R(I,J,KR)**2 + R(J,I,KR)**2
+ 50 SUM(I,J)=SUM(I,J) + sm
+ 100 DEG(I)=DEG(I)+SUM(I,J)
+
+ IQUIT=0
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+! IF(DEG(J).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+! J-->K, K-->J IN SECOND ITERATION
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMIN=10000000000.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+! 0 should be allowed as a best fit for small values IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM=0.0
+ DO 300 KR=1,NR
+300 summ = summ + (R(I,K,KR) - R(J,M,KR)) **2 + (R(K,i,KR) - R(M,j,KR)) **2
+ CMIKJM = max (Summ, sum(i,k) * b (max (k,m), min (k,m)))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=DEG(II)+DEG(JJ)
+ IF(CMIKJM.LT.XMIN) XMIN= CMIKJM
+
+ IF(XMIN.EQ.0) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR DISTANCE NUMERATOR FOR I,J
+ 450 CM=CM+XMIN
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR DISTANCE
+ 506 DM = DEG(II)+DEG(JJ)
+! REMEMBER BOTH POINTS TAKEN AS REFERENCE
+ if(cm.gt.dm) cm=DM
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+! DIFF = B(II,JJ) - B (JJ,II)
+! IF(DIFF.LT.0.0) DIFF = -DIFF
+! D = D + DIFF
+ 510 CONTINUE
+ 520 CONTINUE
+
+! (D.EQ.0.0.AND.L.NE.1).OR.
+ IF(L.EQ.ITER) IQUIT=1
+
+
+! symmetrize : to lower half matrix
+ DO 650 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+ 650 CONTINUE
+
+ DO K = 1, 15
+! compute row and col totals of B
+
+ DO I = 1, N
+ Row(i)= 0.0
+ Col(i)= 0.0
+ ENDDO
+
+ DO I = 1, N
+ DO J = 1, N
+ Row(i)= Row(i)+B(I,j)
+ Col(j)= Col(j)+B(I,j)
+ ENDDO
+ ENDDO
+! normalize the B matrix and symmetrize
+ DO I = 2, N
+ DO J = 1, i-1
+ If (row(i).gt.0.and.col(j).gt.0) then
+ B(I,j)=(B(I,j)/Row(i)**.5) /col(j)**.5
+
+ B(J,I)=B(I,J)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO ! end of normalization
+
+ IF(IQUIT.EQ.1) GO TO 800
+
+ 700 CONTINUE
+ 800 CONTINUE
+
+ END
diff --git a/src/REGD_OW_NE_R.f90 b/src/REGD_OW_NE_R.f90
new file mode 100644
index 0000000..c9e797d
--- /dev/null
+++ b/src/REGD_OW_NE_R.f90
@@ -0,0 +1,132 @@
+! REGD_OW_NE_R.F Ales Ziberna, 2006 - ONEWAY version of REGD (Douglas R. White, 1985)
+ subroutine regdowne(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM1, SUMM2, XMIN1, XMIN2, CMIKJM1, CMIKJM2, CM, Row, Col
+ INTEGER NR, N, ITER, KR, JJ, II
+ DIMENSION DEG (N), SUM (N,N), R (N,N, NR), B (N,N), Row(N), Col(N)
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL DISTANCE
+ DO 100 I=1,N
+ DO 100 J=1,N
+ SUM(I,J)=0.0
+ DO 50 KR=1,NR
+ SM = R(I,J,KR)**2
+ 50 SUM(I,J)=SUM(I,J) + SM
+ 100 CONTINUE
+ DO 101 I=1,N
+ DEG(I)=0.0
+ DO 101 J=1,N
+ 101 DEG(I)=DEG(I)+SUM(I,J)+SUM(J,I)
+
+! IQUIT=0
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+! IF(DEG(J).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+! J-->K, K-->J IN SECOND ITERATION
+ 120 DO 500 K=1,N
+ IF((SUM(I,K)+SUM(K,I)).EQ.0.0) GO TO 500
+ XMIN1=10000000000.0
+ XMIN2=10000000000.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+! 0 should be allowed as a best fit for small values IF((SUM(J,M)+SUM(M,J)).EQ.0.0) GO TO 400
+ SUMM1=0.0
+ SUMM2=0.0
+ DO 300 KR=1,NR
+ IF(R(I,K,KR).NE.0.0) summ1 = summ1 + (R(I,K,KR) - R(J,M,KR)) **2
+300 IF(R(K,I,KR).NE.0.0) summ2 = summ2 + (R(K,I,KR) - R(M,J,KR)) **2
+ CMIKJM1 = max (summ1, sum(i,k) * b (max (k,m), min (k,m)))
+ CMIKJM2 = max (summ2, sum(k,i) * b (max (k,m), min (k,m)))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=DEG(II)+DEG(JJ)
+ IF(CMIKJM1.LT.XMIN1) XMIN1= CMIKJM1
+ IF(CMIKJM2.LT.XMIN2) XMIN2= CMIKJM2
+! call intpr("I",-1,I,1)
+! call intpr("K",-1,K,1)
+! call intpr("J",-1,J,1)
+! call intpr("M",-1,M,1)
+! call dblepr("XMIN1",-1,XMIN1,1)
+! call dblepr("XMIN2",-1,XMIN2,1)
+
+
+
+
+
+ IF((XMIN1+XMIN2).EQ.0) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR DISTANCE NUMERATOR FOR I,J
+ 450 CM=CM+XMIN1+XMIN2
+! call dblepr("CM",-1,CM,1)
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR DISTANCE
+ 506 DM = DEG(II)+DEG(JJ)
+! REMEMBER BOTH POINTS TAKEN AS REFERENCE
+ if(cm.gt.dm) cm=DM
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+! DIFF = B(II,JJ) - B (JJ,II)
+! IF(DIFF.LT.0.0) DIFF = -DIFF
+! D = D + DIFF
+ 510 CONTINUE
+ 520 CONTINUE
+! (D.EQ.0.0.AND.L.NE.1).OR.
+! symmetrize : to lower half matrix
+ DO 650 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+ 650 CONTINUE
+
+ DO K = 1, 15
+! compute row and col totals of B
+
+ DO I = 1, N
+ Row(i)= 0.0
+ Col(i)= 0.0
+ ENDDO
+
+ DO I = 1, N
+ DO J = 1, N
+ Row(i)= Row(i)+B(I,j)
+ Col(j)= Col(j)+B(I,j)
+ ENDDO
+ ENDDO
+! normalize the B matrix and symmetrize
+ DO I = 2, N
+ DO J = 1, i-1
+ If (row(i).gt.0.and.col(j).gt.0) then
+ B(I,j)=(B(I,j)/Row(i)**.5) /col(j)**.5
+
+ B(J,I)=B(I,J)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO ! end of normalization
+
+! IF(IQUIT.EQ.1) GO TO 800
+
+ 700 CONTINUE
+ 800 CONTINUE
+
+ END
diff --git a/src/REGD_OW_R.f90 b/src/REGD_OW_R.f90
new file mode 100644
index 0000000..cc5175d
--- /dev/null
+++ b/src/REGD_OW_R.f90
@@ -0,0 +1,104 @@
+! REGD_OW_R.F Ales Ziberna, 2006 - ONEWAY version of REGD (Douglas R. White, 1985)
+ subroutine regdow(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM1, SUMM2, XMIN1, XMIN2, CMIKJM1, CMIKJM2, CM
+ INTEGER NR, N, ITER, KR, JJ, II
+ DIMENSION DEG (N), SUM (N,N), R (N,N, NR), B (N,N)
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL DISTANCE
+ DO 100 I=1,N
+ DO 100 J=1,N
+ SUM(I,J)=0.0
+ DO 50 KR=1,NR
+ SM = R(I,J,KR)**2
+ 50 SUM(I,J)=SUM(I,J) + SM
+ 100 CONTINUE
+ DO 101 I=1,N
+ DEG(I)=0.0
+ DO 101 J=1,N
+ 101 DEG(I)=DEG(I)+SUM(I,J)+SUM(J,I)
+
+! IQUIT=0
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+! IF(DEG(J).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+! J-->K, K-->J IN SECOND ITERATION
+ 120 DO 500 K=1,N
+ IF((SUM(I,K)+SUM(K,I)).EQ.0.0) GO TO 500
+ XMIN1=10000000000.0
+ XMIN2=10000000000.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+! 0 should be allowed as a best fit for small values IF((SUM(J,M)+SUM(M,J)).EQ.0.0) GO TO 400
+ SUMM1=0.0
+ SUMM2=0.0
+ DO 300 KR=1,NR
+ IF(R(I,K,KR).NE.0.0) summ1 = summ1 + (R(I,K,KR) - R(J,M,KR)) **2
+300 IF(R(K,I,KR).NE.0.0) summ2 = summ2 + (R(K,I,KR) - R(M,J,KR)) **2
+ CMIKJM1 = max (summ1, sum(i,k) * b (max (k,m), min (k,m)))
+ CMIKJM2 = max (summ2, sum(k,i) * b (max (k,m), min (k,m)))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=DEG(II)+DEG(JJ)
+ IF(CMIKJM1.LT.XMIN1) XMIN1= CMIKJM1
+ IF(CMIKJM2.LT.XMIN2) XMIN2= CMIKJM2
+! call intpr("I",-1,I,1)
+! call intpr("K",-1,K,1)
+! call intpr("J",-1,J,1)
+! call intpr("M",-1,M,1)
+! call dblepr("XMIN1",-1,XMIN1,1)
+! call dblepr("XMIN2",-1,XMIN2,1)
+
+
+
+
+
+ IF((XMIN1+XMIN2).EQ.0) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR DISTANCE NUMERATOR FOR I,J
+ 450 CM=CM+XMIN1+XMIN2
+! call dblepr("CM",-1,CM,1)
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR DISTANCE
+ 506 DM = DEG(II)+DEG(JJ)
+! REMEMBER BOTH POINTS TAKEN AS REFERENCE
+ if(cm.gt.dm) cm=DM
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+! DIFF = B(II,JJ) - B (JJ,II)
+! IF(DIFF.LT.0.0) DIFF = -DIFF
+! D = D + DIFF
+ 510 CONTINUE
+ 520 CONTINUE
+! (D.EQ.0.0.AND.L.NE.1).OR.
+! symmetrize : to lower half matrix
+ DO 650 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+ 650 CONTINUE
+
+
+ 700 CONTINUE
+ 800 CONTINUE
+
+ END
diff --git a/src/REGD_R.f90 b/src/REGD_R.f90
new file mode 100644
index 0000000..2b053da
--- /dev/null
+++ b/src/REGD_R.f90
@@ -0,0 +1,88 @@
+! REGDI.FOR 3/18/85 - DOUG WHITE'S REGULAR DISTANCES PROGRAM
+ subroutine regd(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, CM
+ INTEGER NR, N, ITER, KR, JJ, II
+ DIMENSION DEG (N), SUM (N,N), R (N,N, NR), B (N,N)
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL DISTANCE
+ DO 100 I=1,N
+ DEG(I)=0.0
+ DO 100 J=1,N
+ SUM(I,J)=0.0
+ DO 50 KR=1,NR
+ SM = R(I,J,KR)**2 + R(J,I,KR)**2
+ 50 SUM(I,J)=SUM(I,J) + sm
+ 100 DEG(I)=DEG(I)+SUM(I,J)
+
+ IQUIT=0
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+! IF(DEG(J).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+! J-->K, K-->J IN SECOND ITERATION
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMIN=10000000000.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+! 0 should be allowed as a best fit for small values IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM=0.0
+ DO 300 KR=1,NR
+300 summ = summ + (R(I,K,KR) - R(J,M,KR)) **2 + (R(K,i,KR) - R(M,j,KR)) **2
+ CMIKJM = max (Summ, sum(i,k) * b (max (k,m), min (k,m)))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=DEG(II)+DEG(JJ)
+ IF(CMIKJM.LT.XMIN) XMIN= CMIKJM
+
+ IF(XMIN.EQ.0) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR DISTANCE NUMERATOR FOR I,J
+ 450 CM=CM+XMIN
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR DISTANCE
+ 506 DM = DEG(II)+DEG(JJ)
+! REMEMBER BOTH POINTS TAKEN AS REFERENCE
+ if(cm.gt.dm) cm=DM
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+! DIFF = B(II,JJ) - B (JJ,II)
+! IF(DIFF.LT.0.0) DIFF = -DIFF
+! D = D + DIFF
+ 510 CONTINUE
+ 520 CONTINUE
+
+! (D.EQ.0.0.AND.L.NE.1).OR.
+ IF(L.EQ.ITER) IQUIT=1
+! symmetrize : to lower half matrix
+ DO 650 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+ 650 CONTINUE
+
+ IF(IQUIT.EQ.1) GO TO 800
+
+ 700 CONTINUE
+ 800 CONTINUE
+
+ END
diff --git a/src/REGE_NE_R.f90 b/src/REGE_NE_R.f90
new file mode 100644
index 0000000..06ae3d1
--- /dev/null
+++ b/src/REGE_NE_R.f90
@@ -0,0 +1,116 @@
+! REGE_NE_R.F Ales Ziberna, 2006 - NORMALIZED EQUIVALENCES NORMALIZED MATRICES version of REGE (Douglas R. White, 1985)
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine regene(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, xxmax, row, col
+ INTEGER NR, N, ITER, KR, JJ, II, NumIter
+ DIMENSION DEG (N), SUM (N,N), R (N,N, NR), B (N,N), row(N), col(N)
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I)=0.0
+ DO 100 J=1,N
+ SUM(I,J)=0.0
+ DO 50 KR=1,NR
+ 50 SUM(I,J)=SUM(I,J)+R(I,J,KR)+R(J,I,KR)
+ 100 DEG(I)=DEG(I)+SUM(I,J)
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF(DEG(J).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMAX=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM=0.0
+ DO 300 KR=1,NR
+ 300 SUMM = SUMM +min (R(I,K,KR),r(j,m,kr)) +min (R(K,I,KR),r(m,j,kr))
+ CMIKJM = SUMM * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM.GT.XMAX) XMAX= CMIKJM
+
+ IF(XMAX.EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+
+
+! Start normalization
+ NumIter=15
+ DO K = 1, NumIter
+ Xxmax=0.0
+
+
+! compute row and col totals of B
+ DO I = 1, N
+ B(I,I)=0.0
+ Row(i)= 0.0
+ Col(i)= 0.0
+ ENDDO
+
+ DO I = 1, N
+ DO J = 1, N
+ IF (xxmax.lt.B(I,J)) then
+ xxmax=B(I,J)
+ ENDIF
+ Row(i)= Row(i)+B(I,j)
+ Col(j)= Col(j)+B(I,j)
+ ENDDO
+ ENDDO
+
+! normalize the B matrix and symmetrize
+ DO I = 2, N
+ DO J = 1, i-1
+ If (row(i).gt.0.and.col(j).gt.0) then
+ B(I,j)=(B(I,j)/Row(i)**.5) /col(j)**.5
+ B(J,I)=B(I,J)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO ! end of normalization
+
+ DO I = 1, N
+ B(I,I)=xxmax
+ ENDDO
+
+
+ 700 CONTINUE
+
+ END
diff --git a/src/REGE_NM_DIAG_R.f90 b/src/REGE_NM_DIAG_R.f90
new file mode 100644
index 0000000..4ae9dc5
--- /dev/null
+++ b/src/REGE_NM_DIAG_R.f90
@@ -0,0 +1,76 @@
+! REGE_NM_R.F Ales Ziberna, 2006 - NORMALIZED MATRICES version of REGE (Douglas R. White, 1985)
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine regenmdiag(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM, XMAX, CMIKJM
+ INTEGER NR, N, ITER, JJ, II !, KR
+ DIMENSION DEG (N), SUM (N,N),R (N,N, NR), B (N,N)
+
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I) = 0.0
+ DO 100 J=1,N
+ SUM(I,J)= R(I,J,1) + R(J,I,2)
+ 100 DEG(I)=DEG(I) + SUM(I,J)
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF((DEG(J)).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ IF(I.EQ.K) GO TO 500
+ XMAX=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ IF(J.EQ.M) GO TO 400
+ SUMM=0.0
+! DO 300 KR=1,NR
+ 300 SUMM = SUMM + min (R(I,K,1),r(j,m,1)) + min (R(K,I,2),r(m,j,2))
+ CMIKJM = SUMM * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM.GT.XMAX) XMAX= CMIKJM
+
+ IF(XMAX.EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX
+ 500 CONTINUE
+ CM=CM + b (max (i,j), min (i,j))*(min(R(I,I,1),r(j,j,1))+min(R(I,I,2),r(j,j,2)))
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+ 700 CONTINUE
+
+ END
diff --git a/src/REGE_NM_NE_R.f90 b/src/REGE_NM_NE_R.f90
new file mode 100644
index 0000000..1fae1ac
--- /dev/null
+++ b/src/REGE_NM_NE_R.f90
@@ -0,0 +1,115 @@
+! REGE_NM_NE_R.F Ales Ziberna, 2006 - NORMALIZED EQUIVALENCES NORMALIZED MATRICES version of REGE (Douglas R. White, 1985)
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine regenmne(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM, XMAX, CMIKJM, xxmax, row, col
+ INTEGER NR, N, ITER, JJ, II !, KR
+ DIMENSION DEG (N), SUM (N,N),R (N,N, NR), B (N,N), row(N), col(N)
+
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I) = 0.0
+ DO 100 J=1,N
+ SUM(I,J)= R(I,J,1) + R(J,I,2)
+ 100 DEG(I)=DEG(I) + SUM(I,J)
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF((DEG(J)).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMAX=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM=0.0
+! DO 300 KR=1,NR
+ 300 SUMM = SUMM + min (R(I,K,1),r(j,m,1)) + min (R(K,I,2),r(m,j,2))
+ CMIKJM = SUMM * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM.GT.XMAX) XMAX= CMIKJM
+
+ IF(XMAX.EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+
+
+! Start normalization
+ NumIter=15
+ DO K = 1, NumIter
+ Xxmax=0.0
+
+
+! compute row and col totals of B
+ DO I = 1, N
+ B(I,I)=0.0
+ Row(i)= 0.0
+ Col(i)= 0.0
+ ENDDO
+
+ DO I = 1, N
+ DO J = 1, N
+ IF (xxmax.lt.B(I,J)) then
+ xxmax=B(I,J)
+ ENDIF
+ Row(i)= Row(i)+B(I,j)
+ Col(j)= Col(j)+B(I,j)
+ ENDDO
+ ENDDO
+
+! normalize the B matrix and symmetrize
+ DO I = 2, N
+ DO J = 1, i-1
+ If (row(i).gt.0.and.col(j).gt.0) then
+ B(I,j)=(B(I,j)/Row(i)**.5) /col(j)**.5
+ B(J,I)=B(I,J)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO ! end of normalization
+
+ DO I = 1, N
+ B(I,I)=xxmax
+ ENDDO
+
+
+ 700 CONTINUE
+
+ END
diff --git a/src/REGE_NM_R.f90 b/src/REGE_NM_R.f90
new file mode 100644
index 0000000..c1e2a52
--- /dev/null
+++ b/src/REGE_NM_R.f90
@@ -0,0 +1,73 @@
+! REGE_NM_R.F Ales Ziberna, 2006 - NORMALIZED MATRICES version of REGE (Douglas R. White, 1985)
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine regenm(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM, XMAX, CMIKJM
+ INTEGER NR, N, ITER, JJ, II !, KR
+ DIMENSION DEG (N), SUM (N,N),R (N,N, NR), B (N,N)
+
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I) = 0.0
+ DO 100 J=1,N
+ SUM(I,J)= R(I,J,1) + R(J,I,2)
+ 100 DEG(I)=DEG(I) + SUM(I,J)
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF((DEG(J)).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMAX=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM=0.0
+! DO 300 KR=1,NR
+ 300 SUMM = SUMM + min (R(I,K,1),r(j,m,1)) + min (R(K,I,2),r(m,j,2))
+ CMIKJM = SUMM * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM.GT.XMAX) XMAX= CMIKJM
+
+ IF(XMAX.EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+ 700 CONTINUE
+
+ END
diff --git a/src/REGE_OWNM_DIAG_R.f90 b/src/REGE_OWNM_DIAG_R.f90
new file mode 100644
index 0000000..95f52d3
--- /dev/null
+++ b/src/REGE_OWNM_DIAG_R.f90
@@ -0,0 +1,82 @@
+! REGE_OWNM_R.F Ales Ziberna, 2006 - ONE WAY, NORMALIZED MATRICES version of REGE (Douglas R. White, 1985)
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine regeownmdiag(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM1, SUMM2, XMAX1, XMAX2, CMIKJM1, CMIKJM2
+ INTEGER NR, N, ITER, JJ, II !, KR
+ DIMENSION DEG (N), SUM (N,N),R (N,N, NR), B (N,N)
+
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I) = 0.0
+ DO 100 J=1,N
+ SUM(I,J)= R(I,J,1) + R(J,I,2)
+ 100 DEG(I)=DEG(I) + SUM(I,J)
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF((DEG(J)).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ IF (I.EQ.K) GO TO 500
+ XMAX1=0.0
+ XMAX2=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ IF(J.EQ.M) GO TO 400
+ SUMM1=0.0
+ SUMM2=0.0
+! DO 300 KR=1,NR
+ SUMM1 = SUMM1 +min (R(I,K,1),r(j,m,1))
+ SUMM2 = SUMM2 +min (R(K,I,2),r(m,j,2))
+! 300
+ CMIKJM1 = SUMM1 * b (max (k,m), min (k,m))
+ CMIKJM2 = SUMM2 * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM1.GT.XMAX1) XMAX1= CMIKJM1
+ IF(CMIKJM2.GT.XMAX2) XMAX2= CMIKJM2
+
+ IF((XMAX1 + XMAX2).EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX1 + XMAX2
+ 500 CONTINUE
+ CM=CM + b (max (i,j), min (i,j))*(min(R(I,I,1),r(j,j,1))+min(R(I,I,2),r(j,j,2)))
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+ 700 CONTINUE
+
+ END
diff --git a/src/REGE_OWNM_NE_R.f90 b/src/REGE_OWNM_NE_R.f90
new file mode 100644
index 0000000..bd775f5
--- /dev/null
+++ b/src/REGE_OWNM_NE_R.f90
@@ -0,0 +1,121 @@
+! REGE_OWNM_NE_R.F Ales Ziberna, 2006 - NORMALIZED EQUIVALENCES, ONE WAY, NORMALIZED MATRICES version of REGE (Douglas R. White, 1985)
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine regeownmne(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM1, SUMM2, XMAX1, XMAX2, CMIKJM1, CMIKJM2, xxmax, row, col
+ INTEGER NR, N, ITER, JJ, II !, KR
+ DIMENSION DEG (N), SUM (N,N),R (N,N, NR), B (N,N), row(N), col(N)
+
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I) = 0.0
+ DO 100 J=1,N
+ SUM(I,J)= R(I,J,1) + R(J,I,2)
+ 100 DEG(I)=DEG(I) + SUM(I,J)
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF((DEG(J)).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMAX1=0.0
+ XMAX2=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM1=0.0
+ SUMM2=0.0
+! DO 300 KR=1,NR
+ SUMM1 = SUMM1 +min (R(I,K,1),r(j,m,1))
+ SUMM2 = SUMM2 +min (R(K,I,2),r(m,j,2))
+! 300
+ CMIKJM1 = SUMM1 * b (max (k,m), min (k,m))
+ CMIKJM2 = SUMM2 * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM1.GT.XMAX1) XMAX1= CMIKJM1
+ IF(CMIKJM2.GT.XMAX2) XMAX2= CMIKJM2
+
+ IF((XMAX1 + XMAX2).EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX1 + XMAX2
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+
+
+! Start normalization
+ NumIter=15
+ DO K = 1, NumIter
+ Xxmax=0.0
+
+
+! compute row and col totals of B
+ DO I = 1, N
+ B(I,I)=0.0
+ Row(i)= 0.0
+ Col(i)= 0.0
+ ENDDO
+
+ DO I = 1, N
+ DO J = 1, N
+ IF (xxmax.lt.B(I,J)) then
+ xxmax=B(I,J)
+ ENDIF
+ Row(i)= Row(i)+B(I,j)
+ Col(j)= Col(j)+B(I,j)
+ ENDDO
+ ENDDO
+
+! normalize the B matrix and symmetrize
+ DO I = 2, N
+ DO J = 1, i-1
+ If (row(i).gt.0.and.col(j).gt.0) then
+ B(I,j)=(B(I,j)/Row(i)**.5) /col(j)**.5
+ B(J,I)=B(I,J)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO ! end of normalization
+
+ DO I = 1, N
+ B(I,I)=xxmax
+ ENDDO
+
+
+ 700 CONTINUE
+
+ END
diff --git a/src/REGE_OWNM_R.f90 b/src/REGE_OWNM_R.f90
new file mode 100644
index 0000000..a46a68d
--- /dev/null
+++ b/src/REGE_OWNM_R.f90
@@ -0,0 +1,79 @@
+! REGE_OWNM_R.F Ales Ziberna, 2006 - ONE WAY, NORMALIZED MATRICES version of REGE (Douglas R. White, 1985)
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine regeownm(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM1, SUMM2, XMAX1, XMAX2, CMIKJM1, CMIKJM2
+ INTEGER NR, N, ITER, JJ, II !, KR
+ DIMENSION DEG (N), SUM (N,N),R (N,N, NR), B (N,N)
+
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I) = 0.0
+ DO 100 J=1,N
+ SUM(I,J)= R(I,J,1) + R(J,I,2)
+ 100 DEG(I)=DEG(I) + SUM(I,J)
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF((DEG(J)).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMAX1=0.0
+ XMAX2=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM1=0.0
+ SUMM2=0.0
+! DO 300 KR=1,NR
+ SUMM1 = SUMM1 +min (R(I,K,1),r(j,m,1))
+ SUMM2 = SUMM2 +min (R(K,I,2),r(m,j,2))
+! 300
+ CMIKJM1 = SUMM1 * b (max (k,m), min (k,m))
+ CMIKJM2 = SUMM2 * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM1.GT.XMAX1) XMAX1= CMIKJM1
+ IF(CMIKJM2.GT.XMAX2) XMAX2= CMIKJM2
+
+ IF((XMAX1 + XMAX2).EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX1 + XMAX2
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+ 700 CONTINUE
+
+ END
diff --git a/src/REGE_OW_NE_R.f90 b/src/REGE_OW_NE_R.f90
new file mode 100644
index 0000000..e058ece
--- /dev/null
+++ b/src/REGE_OW_NE_R.f90
@@ -0,0 +1,121 @@
+! REGE_OW_NE_R.F Ales Ziberna, 2006 - NORMALITED EQUIVALENCES, ONEWAY version of REGE (Douglas R. White, 1985)
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine regeowne(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM1, SUMM2, XMAX1, XMAX2, CMIKJM1, CMIKJM2, xxmax, row, col
+ INTEGER NR, N, ITER, KR, JJ, II
+ DIMENSION DEG (N), SUM (N,N), R (N,N, NR), B (N,N), row(N), col(N)
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I)=0.0
+ DO 100 J=1,N
+ SUM(I,J)=0.0
+ DO 50 KR=1,NR
+ 50 SUM(I,J)=SUM(I,J)+R(I,J,KR)+R(J,I,KR)
+ 100 DEG(I)=DEG(I)+SUM(I,J)
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF(DEG(J).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMAX1=0.0
+ XMAX2=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM1=0.0
+ SUMM2=0.0
+ DO 300 KR=1,NR
+ SUMM1 = SUMM1 +min (R(I,K,KR),r(j,m,kr))
+ 300 SUMM2 = SUMM2 +min (R(K,I,KR),r(m,j,kr))
+ CMIKJM1 = SUMM1 * b (max (k,m), min (k,m))
+ CMIKJM2 = SUMM2 * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM1.GT.XMAX1) XMAX1= CMIKJM1
+ IF(CMIKJM2.GT.XMAX2) XMAX2= CMIKJM2
+
+ IF((XMAX1 + XMAX2).EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX1 + XMAX2
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+
+
+! Start normalization
+ NumIter=15
+ DO K = 1, NumIter
+ Xxmax=0.0
+
+
+! compute row and col totals of B
+ DO I = 1, N
+ B(I,I)=0.0
+ Row(i)= 0.0
+ Col(i)= 0.0
+ ENDDO
+
+ DO I = 1, N
+ DO J = 1, N
+ IF (xxmax.lt.B(I,J)) then
+ xxmax=B(I,J)
+ ENDIF
+ Row(i)= Row(i)+B(I,j)
+ Col(j)= Col(j)+B(I,j)
+ ENDDO
+ ENDDO
+
+! normalize the B matrix and symmetrize
+ DO I = 2, N
+ DO J = 1, i-1
+ If (row(i).gt.0.and.col(j).gt.0) then
+ B(I,j)=(B(I,j)/Row(i)**.5) /col(j)**.5
+ B(J,I)=B(I,J)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO ! end of normalization
+
+ DO I = 1, N
+ B(I,I)=xxmax
+ ENDDO
+
+
+ 700 CONTINUE
+
+ END
diff --git a/src/REGE_OW_R.f90 b/src/REGE_OW_R.f90
new file mode 100644
index 0000000..80d3d8a
--- /dev/null
+++ b/src/REGE_OW_R.f90
@@ -0,0 +1,81 @@
+! REGE_OW_R.F Ales Ziberna, 2006 - ONEWAY version of REGE (Douglas R. White, 1985)
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine regeow(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM, SUMM1, SUMM2, XMAX1, XMAX2, CMIKJM1, CMIKJM2
+ INTEGER NR, N, ITER, KR, JJ, II
+ DIMENSION DEG (N), SUM (N,N), R (N,N, NR), B (N,N)
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I)=0.0
+ DO 100 J=1,N
+ SUM(I,J)=0.0
+ DO 50 KR=1,NR
+ 50 SUM(I,J)=SUM(I,J)+R(I,J,KR)+R(J,I,KR)
+ 100 DEG(I)=DEG(I)+SUM(I,J)
+ D = 100.0
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ IF (D.EQ.0.0) GO TO 1000
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM= 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF(DEG(J).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMAX1=0.0
+ XMAX2=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM1=0.0
+ SUMM2=0.0
+ DO 300 KR=1,NR
+ SUMM1 = SUMM1 +min (R(I,K,KR),r(j,m,kr))
+ 300 SUMM2 = SUMM2 +min (R(K,I,KR),r(m,j,kr))
+ CMIKJM1 = SUMM1 * b (max (k,m), min (k,m))
+ CMIKJM2 = SUMM2 * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM1.GT.XMAX1) XMAX1= CMIKJM1
+ IF(CMIKJM2.GT.XMAX2) XMAX2= CMIKJM2
+
+ IF((XMAX1 + XMAX2).EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX1 + XMAX2
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ D=0.0
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ D = D + (B(i,j) - B(j,i) )**2
+ 600 B(i,j) = B(j,i)
+ 700 CONTINUE
+
+ 1000 END
diff --git a/src/REGE_R.f90 b/src/REGE_R.f90
new file mode 100644
index 0000000..29ea78b
--- /dev/null
+++ b/src/REGE_R.f90
@@ -0,0 +1,74 @@
+! REGGE.FOR 3/18/85 - DOUG WHITE'S REGULAR EQUIVALENCE PROGRAM
+! THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS
+ subroutine rege(R,B,N,NR,ITER)
+ DOUBLE PRECISION R, B, DEG, SUM
+ INTEGER NR, N, ITER, KR, JJ, II
+ DIMENSION DEG (N), SUM (N,N), R (N,N, NR), B (N,N)
+
+! COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
+ DO 100 I=1,N
+ DEG(I)=0.0
+ DO 100 J=1,N
+ SUM(I,J)=0.0
+ DO 50 KR=1,NR
+ 50 SUM(I,J)=SUM(I,J)+R(I,J,KR)+R(J,I,KR)
+ 100 DEG(I)=DEG(I)+SUM(I,J)
+
+! BEGIN ITERATIONS
+ DO 700 L=1,ITER
+! INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
+ D = 0.0
+! TAKE POINT I
+ DO 520 II = 1, N-1
+ I=II
+! IF DEGREE ZERO NEXT I
+! IF(DEG(I).EQ.0.0) GO TO 520
+! TAKE POINT J
+ DO 510 JJ= II+1, N
+ CM = 0.0
+ J=JJ
+! IF DEGREE ZERO NEXT J
+ IF(DEG(J).EQ.0.0) GO TO 506
+ I=II
+! TAKE EACH OF THE TWO POINTS AS REFERENT
+ DO 505 IJ=1,2
+ IF (IJ.EQ.1) GOTO 120
+ J=II
+ I=JJ
+! TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
+ 120 DO 500 K=1,N
+ IF(SUM(I,K).EQ.0.0) GO TO 500
+ XMAX=0.0
+! FIND BEST MATCHING POINT M
+ DO 400 M=1,N
+ IF(SUM(J,M).EQ.0.0) GO TO 400
+ SUMM=0.0
+ DO 300 KR=1,NR
+ 300 SUMM = SUMM +min (R(I,K,KR),r(j,m,kr)) +min (R(K,I,KR),r(m,j,kr))
+ CMIKJM = SUMM * b (max (k,m), min (k,m))
+! IF PERFECT MATCH DESIRED, CORRECT MATCH
+! IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1) CMIKJM=0.0
+ IF(CMIKJM.GT.XMAX) XMAX= CMIKJM
+
+ IF(XMAX.EQ.SUM(I,K)) GO TO 450
+
+ 400 CONTINUE
+! ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
+ 450 CM=CM+XMAX
+ 500 CONTINUE
+ 505 CONTINUE
+! COMPUTE REGULAR EQUIVALENCE
+ 506 DM = DEG(II)+DEG(JJ)
+ B (II,JJ)= 1.0
+ IF(DM.NE.0.0) B (II,JJ)=CM/DM
+! IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
+ 510 CONTINUE
+ 520 CONTINUE
+
+! symmetrize : to lower half matrix
+ DO 600 I = 2, N
+ DO 600 J = 1, i-1
+ 600 B(i,j) = B(j,i)
+ 700 CONTINUE
+
+ END
diff --git a/src/opt_par_ss_com.f90 b/src/opt_par_ss_com.f90
new file mode 100644
index 0000000..6e5ff9c
--- /dev/null
+++ b/src/opt_par_ss_com.f90
@@ -0,0 +1,379 @@
+subroutine optparsscom(M,clu,diag,maxiter,n,k,err,E,BM,cluM,nbest,iter,printIter)
+ INTEGER iter, maxiter, n, clu, nclu, bnclu, iclu, k, i, j, ii, jj, cluM, nbest, nA, nAD, tnA, tnAD, bnA, bnAD, bclu, oldiclu
+ DOUBLE PRECISION M, E, BM, err, mean, sumA, sumAD, sumA2, sumAD2, tsumA, tsumAD, tsumA2, tsumAD2, tE, tBM, terr, bsumA, bsumAD
+ DOUBLE PRECISION bsumA2, bsumAD2, bE, bBM, berr
+ LOGICAL diag, imp, printIter
+ DIMENSION M(n,n), clu(n), E(k,k), BM(k,k), cluM(50,n), sumA(k,k), sumAD(k), sumA2(k,k), sumAD2(k), nA(k,k), nAD(k)
+ DIMENSION tE(k,k), tBM(k,k), tsumA(k,k), tsumAD(k), tsumA2(k,k), tsumAD2(k), tnA(k,k), tnAD(k), bE(k,k), bBM(k,k), bclu(n)
+ DIMENSION bsumA(k,k), bsumAD(k), bsumA2(k,k), bsumAD2(k), bnA(k,k), bnAD(k)
+ DIMENSION nclu(k), bnclu(k)
+
+ do i = 1, k
+ nclu(i) = 0
+ nAD(i) = 0
+ sumAD(i) = 0
+ sumAD2(i) = 0
+ do j = 1, k
+ nA(i,j) = 0
+ sumA(i,j) = 0
+ sumA2(i,j) = 0
+ end do
+ end do
+
+ do i = 1, n
+ nclu(clu(i)) = nclu(clu(i)) + 1
+ do j = 1, n
+ if((i.ne.j) .or. (.not.diag)) then
+ nA(clu(i),clu(j)) = nA(clu(i),clu(j)) + 1
+ sumA(clu(i),clu(j)) = sumA(clu(i),clu(j))+M(i,j)
+ sumA2(clu(i),clu(j)) = sumA2(clu(i),clu(j))+M(i,j)**2
+ else
+ nAD(clu(i)) = nAD(clu(i)) + 1
+ sumAD(clu(i)) = sumAD(clu(i))+M(i,i)
+ sumAD2(clu(i)) = sumAD2(clu(i))+M(i,i)**2
+ endif
+
+ end do
+ end do
+
+
+ err = 0.0
+
+ do i = 1, k
+ do j = 1, k
+ if(diag.and.i.eq.j) then
+ if(nA(i,j).eq.0) then
+ E(i,j) = 0
+ mean = sumAD(i)/nAD(i)
+ else
+ mean = sumA(i,j)/nA(i,j)
+ E(i,j) = sumA2(i,j)-nA(i,j)*mean**2 + sumAD2(i)-sumAD(i)**2/nAD(i)
+ end if
+ BM(i,j) = mean
+ err = err + E(i,j)
+ else
+ mean = sumA(i,j)/nA(i,j)
+ E(i,j) = sumA2(i,j)-nA(i,j)*mean**2
+ BM(i,j) = mean
+ err = err + E(i,j)
+ endif
+ end do
+ end do
+
+ nbest = 1
+ berr=err
+ do i = 1, n
+ bclu(i)=clu(i)
+ cluM(nbest,i) = clu(i)
+ end do
+
+ do i = 1, k
+ bnclu(i) = nclu(i)
+ bnAD(i) = nAD(i)
+ bsumAD(i) = sumAD(i)
+ bsumAD2(i) = sumAD2(i)
+
+ do j = 1, k
+ bnA(i,j) = nA(i,j)
+ bsumA(i,j) = sumA(i,j)
+ bsumA2(i,j) = sumA2(i,j)
+ bE(i,j)=E(i,j)
+ bBM(i,j)=BM(i,j)
+ end do
+ end do
+
+ imp = .TRUE.
+ iter = 0
+
+ do while (imp .AND. (iter .LE. maxiter))
+ imp = .FALSE.
+ iter = iter + 1
+
+ do i = 1, n
+ oldiclu=clu(i)
+ if(nclu(oldiclu).gt.1) then
+ do iclu = 1, k
+ if(oldiclu.ne.iclu) then
+ newiclu = iclu
+
+ do ii = 1, k
+ tnAD(ii) = nAD(ii)
+ tsumAD(ii) = sumAD(ii)
+ tsumAD2(ii) = sumAD2(ii)
+
+ do jj = 1, k
+ tnA(ii,jj) = nA(ii,jj)
+ tsumA(ii,jj) = sumA(ii,jj)
+ tsumA2(ii,jj) = sumA2(ii,jj)
+ end do
+ end do
+
+ do j = 1 ,n
+ if(i.ne.j) then
+ tnA(oldiclu,clu(j)) = tnA(oldiclu,clu(j)) - 1
+ tnA(newiclu,clu(j)) = tnA(newiclu,clu(j)) + 1
+ tsumA(oldiclu,clu(j)) = tsumA(oldiclu,clu(j)) - M(i,j)
+ tsumA(newiclu,clu(j)) = tsumA(newiclu,clu(j)) + M(i,j)
+ tsumA2(oldiclu,clu(j)) = tsumA2(oldiclu,clu(j)) - M(i,j)**2
+ tsumA2(newiclu,clu(j)) = tsumA2(newiclu,clu(j)) + M(i,j)**2
+
+ tnA(clu(j),oldiclu) = tnA(clu(j),oldiclu) - 1
+ tnA(clu(j),newiclu) = tnA(clu(j),newiclu) + 1
+ tsumA(clu(j),oldiclu) = tsumA(clu(j),oldiclu) - M(j,i)
+ tsumA(clu(j),newiclu) = tsumA(clu(j),newiclu) + M(j,i)
+ tsumA2(clu(j),oldiclu) = tsumA2(clu(j),oldiclu) - M(j,i)**2
+ tsumA2(clu(j),newiclu) = tsumA2(clu(j),newiclu) + M(j,i)**2
+
+ endif
+ end do
+
+ tnAD(oldiclu) = tnAD(oldiclu) - 1
+ tnAD(newiclu) = tnAD(newiclu) + 1
+ tsumAD(oldiclu) = tsumAD(oldiclu) - M(i,i)
+ tsumAD(newiclu) = tsumAD(newiclu) + M(i,i)
+ tsumAD2(oldiclu) = tsumAD2(oldiclu) - M(i,i)**2
+ tsumAD2(newiclu) = tsumAD2(newiclu) + M(i,i)**2
+
+
+ terr = 0.0
+
+ do ii = 1, k
+ do jj = 1, k
+ if(diag.and.ii.eq.jj) then
+ if(ii.eq.newiclu .or. ii.eq.oldiclu) then
+ if(tnA(ii,jj).eq.0)then
+ mean = tsumAD(ii)/tnAD(ii)
+ tE(ii,jj) = 0
+ else
+ mean = tsumA(ii,jj)/tnA(ii,jj)
+ tE(ii,jj) = tsumA2(ii,jj)-tnA(ii,jj)*mean**2 + tsumAD2(ii)-tsumAD(ii)**2/tnAD(ii)
+ end if
+ tBM(ii,jj) = mean
+ else
+ tE(ii,jj) = E(ii,jj)
+ tBM(ii,jj) = BM(ii,jj)
+ end if
+ terr = terr + tE(ii,jj)
+ else
+ if(ii.eq.newiclu .or. ii.eq.oldiclu .or. jj.eq.newiclu .or. jj.eq.oldiclu) then
+ mean = tsumA(ii,jj)/tnA(ii,jj)
+ tE(ii,jj) = tsumA2(ii,jj)-tnA(ii,jj)*mean**2
+ tBM(ii,jj) = mean
+ else
+ tE(ii,jj) = E(ii,jj)
+ tBM(ii,jj) = BM(ii,jj)
+ end if
+
+ terr = terr + tE(ii,jj)
+ endif
+ end do
+ end do
+
+ if (terr.lt.berr) then
+! call intpr("Move", -1, 1, 1)
+ imp = .TRUE.
+ berr=terr
+ do ii = 1, n
+ bclu(ii)=clu(ii)
+ end do
+
+ do ii = 1, k
+ bnclu(ii) = 0
+ bnAD(ii) = tnAD(ii)
+ bsumAD(ii) = tsumAD(ii)
+ bsumAD2(ii) = tsumAD2(ii)
+
+ do jj = 1, k
+ bnA(ii,jj) = tnA(ii,jj)
+ bsumA(ii,jj) = tsumA(ii,jj)
+ bsumA2(ii,jj) = tsumA2(ii,jj)
+ bE(ii,jj)=tE(ii,jj)
+ bBM(ii,jj)=tBM(ii,jj)
+ end do
+ end do
+
+ bclu(i) = newiclu
+
+ nbest = 1
+ do ii = 1, n
+ bnclu(bclu(ii)) = bnclu(bclu(ii)) + 1
+ cluM(nbest,ii) = bclu(ii)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do ii = 1, n
+ cluM(nbest,ii) = clu(ii)
+ end do
+ cluM(nbest,i) = newiclu
+ endif
+ end if
+ end if
+
+ end if
+ end do
+ end if
+
+ do j = 1, i - 1
+ if(i.ne.j) then
+ if(clu(i).ne.clu(j)) then
+ !tclu = clu
+ !tclu(i) = clu(j)
+ !tclu(j) = clu(i)
+ newiclu = clu(j)
+
+ do ii = 1, k
+ tnAD(ii) = nAD(ii)
+ tsumAD(ii) = sumAD(ii)
+ tsumAD2(ii) = sumAD2(ii)
+ do jj = 1, k
+ tnA(ii,jj) = nA(ii,jj)
+ tsumA(ii,jj) = sumA(ii,jj)
+ tsumA2(ii,jj) = sumA2(ii,jj)
+ end do
+ end do
+
+ do jj = 1, n
+ if(jj.ne.i .and. jj.ne.j) then
+ tsumA(oldiclu,clu(jj)) = tsumA(oldiclu,clu(jj)) - M(i,jj) + M(j,jj)
+ tsumA(newiclu,clu(jj)) = tsumA(newiclu,clu(jj)) + M(i,jj) - M(j,jj)
+ tsumA2(oldiclu,clu(jj)) = tsumA2(oldiclu,clu(jj)) - M(i,jj)**2 + M(j,jj)**2
+ tsumA2(newiclu,clu(jj)) = tsumA2(newiclu,clu(jj)) + M(i,jj)**2 - M(j,jj)**2
+
+ tsumA(clu(jj),oldiclu) = tsumA(clu(jj),oldiclu) - M(jj,i) + M(jj,j)
+ tsumA(clu(jj),newiclu) = tsumA(clu(jj),newiclu) + M(jj,i) - M(jj,j)
+ tsumA2(clu(jj),oldiclu) = tsumA2(clu(jj),oldiclu) - M(jj,i)**2 + M(jj,j)**2
+ tsumA2(clu(jj),newiclu) = tsumA2(clu(jj),newiclu) + M(jj,i)**2 - M(jj,j)**2
+ endif
+ end do
+
+ tsumA(oldiclu,newiclu) = tsumA(oldiclu,newiclu) - M(i,j) + M(j,i)
+ tsumA(newiclu,oldiclu) = tsumA(newiclu,oldiclu) + M(i,j) - M(j,i)
+ tsumA2(oldiclu,newiclu) = tsumA2(oldiclu,newiclu) - M(i,j)**2 + M(j,i)**2
+ tsumA2(newiclu,oldiclu) = tsumA2(newiclu,oldiclu) + M(i,j)**2 - M(j,i)**2
+
+ tsumAD(oldiclu) = tsumAD(oldiclu) - M(i,i) + M(j,j)
+ tsumAD(newiclu) = tsumAD(newiclu) + M(i,i) - M(j,j)
+ tsumAD2(oldiclu) = tsumAD2(oldiclu) - M(i,i)**2 + M(j,j)**2
+ tsumAD2(newiclu) = tsumAD2(newiclu) + M(i,i)**2 - M(j,j)**2
+
+ terr = 0.0
+
+ do ii = 1, k
+ do jj = 1, k
+ if(diag .and. (ii.eq.jj)) then
+ if((ii.eq.newiclu) .or. (ii.eq.oldiclu)) then
+ if(tnA(ii,jj).eq.0)then
+ mean = tsumAD(ii)/tnAD(ii)
+ tE(ii,jj) = 0
+ else
+ mean = tsumA(ii,jj)/tnA(ii,jj)
+ tE(ii,jj) = tsumA2(ii,jj)-tnA(ii,jj)*mean**2 + tsumAD2(ii)-tsumAD(ii)**2/tnAD(ii)
+ end if
+ tBM(ii,jj) = mean
+ else
+ tE(ii,jj) = E(ii,jj)
+ tBM(ii,jj) = BM(ii,jj)
+ end if
+ terr = terr + tE(ii,jj)
+ else
+ if(ii.eq.newiclu .or. ii.eq.oldiclu .or. jj.eq.newiclu .or. jj.eq.oldiclu) then
+ mean = tsumA(ii,jj)/tnA(ii,jj)
+ tE(ii,jj) = tsumA2(ii,jj)-tnA(ii,jj)*mean**2
+ tBM(ii,jj) = mean
+ else
+ tE(ii,jj) = E(ii,jj)
+ tBM(ii,jj) = BM(ii,jj)
+ end if
+
+ terr = terr + tE(ii,jj)
+ endif
+ end do
+ end do
+
+ if(terr.lt.berr)then
+! call intpr("Switch", -1, 2, 1)
+ imp = .TRUE.
+ berr=terr
+ do ii = 1, n
+ bclu(ii)=clu(ii)
+ end do
+ bclu(i) = newiclu
+ bclu(j) = oldiclu
+
+ do ii = 1, k
+ bnclu(ii) = 0
+ bnAD(ii) = tnAD(ii)
+ bsumAD(ii) = tsumAD(ii)
+ bsumAD2(ii) = tsumAD2(ii)
+
+ do jj = 1, k
+ bnA(ii,jj) = tnA(ii,jj)
+ bsumA(ii,jj) = tsumA(ii,jj)
+ bsumA2(ii,jj) = tsumA2(ii,jj)
+ bE(ii,jj) = tE(ii,jj)
+ bBM(ii,jj) = tBM(ii,jj)
+ end do
+ end do
+
+
+ nbest = 1
+ do ii = 1, n
+ bnclu(bclu(ii)) = bnclu(bclu(ii)) + 1
+ cluM(nbest,ii) = bclu(ii)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do ii = 1, n
+ cluM(nbest,ii) = clu(ii)
+ end do
+ cluM(nbest,i) = newiclu
+ cluM(nbest,j) = oldiclu
+ end if
+ end if
+ end if
+ end if
+ end if
+ end do
+ end do
+
+
+ err=berr
+ do i = 1, n
+ clu(i)=bclu(i)
+ end do
+
+ do i = 1, k
+ nclu(i) = bnclu(i)
+ nAD(i) = bnAD(i)
+ sumAD(i) = bsumAD(i)
+ sumAD2(i) = bsumAD2(i)
+
+ do j = 1, k
+ nA(i,j) = bnA(i,j)
+ sumA(i,j) = bsumA(i,j)
+ sumA2(i,j) = bsumA2(i,j)
+ E(i,j) = bE(i,j)
+ BM(i,j) = bBM(i,j)
+ end do
+ end do
+ if (printIter) then
+ call intpr("iter", -1, iter, 1)
+ call intpr("nclu", -1, nclu, k)
+ call intpr("clu", -1, clu, n)
+ call dblepr("err", -1, err, 1)
+ end if
+ enddo
+
+! call intpr("nAD", -1, nAD, k)
+! call dblepr("sumAD", -1, sumAD, k)
+! call dblepr("sumAD2", -1, sumAD2, k)
+! call intpr("nA", -1, nA, k*k)
+! call dblepr("sumA", -1, sumA, k*k)
+! call dblepr("sumA2", -1, sumA2, k*k)
+end
+
+
diff --git a/src/opt_par_ss_com_twoMode.f90 b/src/opt_par_ss_com_twoMode.f90
new file mode 100644
index 0000000..58bb3ed
--- /dev/null
+++ b/src/opt_par_ss_com_twoMode.f90
@@ -0,0 +1,529 @@
+subroutine optparsscomtm(M,clu1,clu2,maxiter,n1,n2,k1,k2,err,E,BM,cluM1,cluM2,nbest,iter,printIter)
+ INTEGER iter, maxiter, n1, n2, clu1, clu2, nclu1, nclu2, bnclu1, bnclu2, iclu, k1, k2, i,i2, j, ii, jj
+ INTEGER nbest, nA, tnA, bnA, bclu1, bclu2, oldiclu, newiclu, cluM1, cluM2
+ DOUBLE PRECISION M, E, BM, err, mean, sumA, sumA2, tsumA, tsumA2, tE, tBM, berr, terr, bsumA, bsumA2, bE, bBM
+ LOGICAL imp, printIter
+ DIMENSION M(n1,n2), clu1(n1), clu2(n2), E(k1,k2), BM(k1,k2), cluM1(50,n1), cluM2(50,n2), sumA(k1,k2), sumA2(k1,k2), nA(k1,k2)
+ DIMENSION tE(k1,k2), tBM(k1,k2), tsumA(k1,k2), tsumA2(k1,k2),tnA(k1,k2), bE(k1,k2), bBM(k1,k2), bclu1(n1), bclu2(n2)
+ DIMENSION bsumA(k1,k2), bsumA2(k1,k2), bnA(k1,k2)
+ DIMENSION nclu1(k1), nclu2(k2), bnclu1(k1), bnclu2(k2)
+
+ do i = 1, k2
+ nclu2(i) = 0
+ end do
+
+ do i = 1, k1
+ nclu1(i) = 0
+ do j = 1, k2
+ nA(i,j) = 0
+ sumA(i,j) = 0.0
+ sumA2(i,j) = 0.0
+ end do
+ end do
+
+ do i = 1, n2
+ nclu2(clu2(i)) = nclu2(clu2(i)) + 1
+ end do
+
+ do i = 1, n1
+ nclu1(clu1(i)) = nclu1(clu1(i)) + 1
+ do j = 1, n2
+ nA(clu1(i),clu2(j)) = nA(clu1(i),clu2(j)) + 1
+ sumA(clu1(i),clu2(j)) = sumA(clu1(i),clu2(j))+M(i,j)
+ sumA2(clu1(i),clu2(j)) = sumA2(clu1(i),clu2(j))+M(i,j)**2
+ end do
+ end do
+
+
+ err = 0.0
+
+ do i = 1, k1
+ do j = 1, k2
+ mean = sumA(i,j)/nA(i,j)
+ E(i,j) = sumA2(i,j)-nA(i,j)*mean**2
+ BM(i,j) = mean
+ err = err + E(i,j)
+ end do
+ end do
+
+ nbest = 1
+ berr=err
+ do i = 1, n1
+ bclu1(i)=clu1(i)
+ cluM1(nbest,i) = clu1(i)
+ end do
+ do i = 1, n2
+ bclu2(i)=clu2(i)
+ cluM2(nbest,i) = clu2(i)
+ end do
+
+ do i = 1, k2
+ bnclu2(i) = nclu2(i)
+ end do
+
+ do i = 1, k1
+ bnclu1(i) = nclu1(i)
+ do j = 1, k2
+ bnA(i,j) = nA(i,j)
+ bsumA(i,j) = sumA(i,j)
+ bsumA2(i,j) = sumA2(i,j)
+ bE(i,j)=E(i,j)
+ bBM(i,j)=BM(i,j)
+ end do
+ end do
+
+ imp = .TRUE.
+ iter = 0
+
+ if (printIter) then
+ call intpr("iter", -1, iter, 1)
+ call intpr("nclu1", -1, nclu1, k1)
+ call intpr("clu1", -1, clu1, n1)
+ call intpr("nclu2", -1, nclu2, k2)
+ call intpr("clu2", -1, clu2, n2)
+ call dblepr("err", -1, err, 1)
+ call dblepr("sumA", -1, sumA, k1*k2)
+ call dblepr("sumA2", -1, sumA2, k1*k2)
+
+ end if
+
+ do while (imp .AND. (iter .LT. maxiter))
+ imp = .FALSE.
+ iter = iter + 1
+
+ do i = 1, n1
+ oldiclu=clu1(i)
+ if(nclu1(oldiclu).gt.1) then
+ do iclu = 1, k1
+ if(oldiclu.ne.iclu) then
+ newiclu = iclu
+
+ do ii = 1, k1
+ do jj = 1, k2
+ tnA(ii,jj) = nA(ii,jj)
+ tsumA(ii,jj) = sumA(ii,jj)
+ tsumA2(ii,jj) = sumA2(ii,jj)
+ end do
+ end do
+
+ do jj = 1, k2
+ tnA(oldiclu,jj) = tnA(oldiclu,jj) - nclu2(jj)
+ tnA(newiclu,jj) = tnA(newiclu,jj) + nclu2(jj)
+ end do
+
+ do j = 1 ,n2
+ tsumA(oldiclu,clu2(j)) = tsumA(oldiclu,clu2(j)) - M(i,j)
+ tsumA(newiclu,clu2(j)) = tsumA(newiclu,clu2(j)) + M(i,j)
+ tsumA2(oldiclu,clu2(j)) = tsumA2(oldiclu,clu2(j)) - M(i,j)**2
+ tsumA2(newiclu,clu2(j)) = tsumA2(newiclu,clu2(j)) + M(i,j)**2
+ end do
+
+
+ terr = 0.0
+
+ do ii = 1, k1
+ do jj = 1, k2
+ if(ii.eq.newiclu .or. ii.eq.oldiclu) then
+ mean = tsumA(ii,jj)/tnA(ii,jj)
+ tE(ii,jj) = tsumA2(ii,jj)-tnA(ii,jj)*mean**2
+ tBM(ii,jj) = mean
+ else
+ tE(ii,jj) = E(ii,jj)
+ tBM(ii,jj) = BM(ii,jj)
+ end if
+
+ terr = terr + tE(ii,jj)
+ end do
+ end do
+
+ if (terr.lt.berr) then
+! call intpr("Move", -1, 1, 1)
+ imp = .TRUE.
+ berr=terr
+ do ii = 1, n1
+ bclu1(ii)=clu1(ii)
+ end do
+
+ do ii = 1, k1
+ bnclu1(ii) = 0
+ do jj = 1, k2
+ bnA(ii,jj) = tnA(ii,jj)
+ bsumA(ii,jj) = tsumA(ii,jj)
+ bsumA2(ii,jj) = tsumA2(ii,jj)
+ bE(ii,jj)=tE(ii,jj)
+ bBM(ii,jj)=tBM(ii,jj)
+ end do
+ end do
+
+ bclu1(i) = newiclu
+
+ nbest = 1
+ do ii = 1, n1
+ bnclu1(bclu1(ii)) = bnclu1(bclu1(ii)) + 1
+ cluM1(nbest,ii) = bclu1(ii)
+ end do
+
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ end do
+ cluM1(nbest,i) = newiclu
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ endif
+ end if
+ end if
+
+ end if
+ end do
+ end if
+
+ do i2 = 1, i - 1
+ if(i.ne.i2) then
+ if(clu1(i).ne.clu1(i2)) then
+ !tclu = clu
+ !tclu(i) = clu(j)
+ !tclu(j) = clu(i)
+ newiclu = clu1(i2)
+
+ do ii = 1, k1
+ do jj = 1, k2
+ tnA(ii,jj) = nA(ii,jj)
+ tsumA(ii,jj) = sumA(ii,jj)
+ tsumA2(ii,jj) = sumA2(ii,jj)
+ end do
+ end do
+
+ do jj = 1, n2
+ tsumA(oldiclu,clu2(jj)) = tsumA(oldiclu,clu2(jj)) - M(i,jj) + M(i2,jj)
+ tsumA(newiclu,clu2(jj)) = tsumA(newiclu,clu2(jj)) + M(i,jj) - M(i2,jj)
+ tsumA2(oldiclu,clu2(jj)) = tsumA2(oldiclu,clu2(jj)) - M(i,jj)**2 + M(i2,jj)**2
+ tsumA2(newiclu,clu2(jj)) = tsumA2(newiclu,clu2(jj)) + M(i,jj)**2 - M(i2,jj)**2
+ end do
+
+
+ terr = 0.0
+
+ do ii = 1, k1
+ do jj = 1, k2
+ if(ii.eq.newiclu .or. ii.eq.oldiclu) then
+ mean = tsumA(ii,jj)/tnA(ii,jj)
+ tE(ii,jj) = tsumA2(ii,jj)-tnA(ii,jj)*mean**2
+ tBM(ii,jj) = mean
+ else
+ tE(ii,jj) = E(ii,jj)
+ tBM(ii,jj) = BM(ii,jj)
+ end if
+
+ terr = terr + tE(ii,jj)
+ end do
+ end do
+
+
+ if(terr.lt.berr) then
+! call intpr("Switch", -1, 2, 1)
+ call dblepr("terr", -1, terr, 1)
+ call dblepr("berr", -1, berr, 1)
+ call dblepr("diff", -1, berr-terr, 1)
+ imp = .TRUE.
+ berr=terr
+ do ii = 1, n1
+ bclu1(ii)=clu1(ii)
+ end do
+ bclu1(i) = newiclu
+ bclu1(i2) = oldiclu
+
+ do ii = 1, k1
+ bnclu1(ii) = 0
+ do jj = 1, k2
+ bnA(ii,jj) = tnA(ii,jj)
+ bsumA(ii,jj) = tsumA(ii,jj)
+ bsumA2(ii,jj) = tsumA2(ii,jj)
+ bE(ii,jj) = tE(ii,jj)
+ bBM(ii,jj) = tBM(ii,jj)
+ end do
+ end do
+
+ nbest = 1
+ do ii = 1, n1
+ bnclu1(bclu1(ii)) = bnclu1(bclu1(ii)) + 1
+ cluM1(nbest,ii) = bclu1(ii)
+ end do
+
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ end do
+ cluM1(nbest,i) = newiclu
+ cluM1(nbest,i2) = oldiclu
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ endif
+ end if
+ end if
+ end if
+ end if
+ end do
+ end do
+
+
+ do j = 1, n2
+ oldiclu=clu2(j)
+ if(nclu2(oldiclu).gt.1) then
+ do iclu = 1, k2
+ if(oldiclu.ne.iclu) then
+ newiclu = iclu
+
+ do ii = 1, k1
+ do jj = 1, k2
+ tnA(ii,jj) = nA(ii,jj)
+ tsumA(ii,jj) = sumA(ii,jj)
+ tsumA2(ii,jj) = sumA2(ii,jj)
+ end do
+ end do
+
+ do ii = 1, k1
+ tnA(ii,oldiclu) = tnA(ii,oldiclu) - nclu1(ii)
+ tnA(ii,newiclu) = tnA(ii,newiclu) + nclu1(ii)
+ end do
+
+ do i = 1 ,n1
+ tsumA(clu1(i),oldiclu) = tsumA(clu1(i),oldiclu) - M(i,j)
+ tsumA(clu1(i),newiclu) = tsumA(clu1(i),newiclu) + M(i,j)
+ tsumA2(clu1(i),oldiclu) = tsumA2(clu1(i),oldiclu) - M(i,j)**2
+ tsumA2(clu1(i),newiclu) = tsumA2(clu1(i),newiclu) + M(i,j)**2
+ end do
+
+
+ terr = 0.0
+
+ do ii = 1, k1
+ do jj = 1, k2
+ if(jj.eq.newiclu .or. jj.eq.oldiclu) then
+ mean = tsumA(ii,jj)/tnA(ii,jj)
+ tE(ii,jj) = tsumA2(ii,jj)-tnA(ii,jj)*mean**2
+ tBM(ii,jj) = mean
+ else
+ tE(ii,jj) = E(ii,jj)
+ tBM(ii,jj) = BM(ii,jj)
+ end if
+
+ terr = terr + tE(ii,jj)
+ end do
+ end do
+
+ if (terr.lt.berr) then
+! call intpr("Move", -1, 1, 1)
+ imp = .TRUE.
+ berr=terr
+ do jj = 1, n2
+ bclu2(jj)=clu2(jj)
+ end do
+
+ do jj = 1, k2
+ bnclu2(jj) = 0
+ do ii = 1, k1
+ bnA(ii,jj) = tnA(ii,jj)
+ bsumA(ii,jj) = tsumA(ii,jj)
+ bsumA2(ii,jj) = tsumA2(ii,jj)
+ bE(ii,jj)=tE(ii,jj)
+ bBM(ii,jj)=tBM(ii,jj)
+ end do
+ end do
+
+ bclu2(j) = newiclu
+
+ nbest = 1
+ do jj = 1, n2
+ bnclu2(bclu2(jj)) = bnclu2(bclu2(jj)) + 1
+ cluM2(nbest,jj) = bclu2(jj)
+ end do
+
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ bclu1(ii)=clu1(ii)
+ end do
+ do ii = 1, k1
+ bnclu1(ii)=nclu1(ii)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ cluM2(nbest,j) = newiclu
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ end do
+ endif
+ end if
+ end if
+
+ end if
+ end do
+ end if
+
+ do j2 = 1, j - 1
+ if(j.ne.j2) then
+ if(clu2(j).ne.clu2(j2)) then
+ !tclu = clu
+ !tclu(i) = clu(j)
+ !tclu(j) = clu(i)
+ newiclu = clu2(j2)
+
+ do ii = 1, k1
+ do jj = 1, k2
+ tnA(ii,jj) = nA(ii,jj)
+ tsumA(ii,jj) = sumA(ii,jj)
+ tsumA2(ii,jj) = sumA2(ii,jj)
+ end do
+ end do
+
+ do ii = 1, n1
+ tsumA(clu1(ii),oldiclu) = tsumA(clu1(ii),oldiclu) - M(ii,j) + M(ii,j2)
+ tsumA(clu1(ii),newiclu) = tsumA(clu1(ii),newiclu) + M(ii,j) - M(ii,j2)
+ tsumA2(clu1(ii),oldiclu) = tsumA2(clu1(ii),oldiclu) - M(ii,j)**2 + M(ii,j2)**2
+ tsumA2(clu1(ii),newiclu) = tsumA2(clu1(ii),newiclu) + M(ii,j)**2 - M(ii,j2)**2
+ end do
+
+
+ terr = 0.0
+
+ do ii = 1, k1
+ do jj = 1, k2
+ if(jj.eq.newiclu .or. jj.eq.oldiclu) then
+ mean = tsumA(ii,jj)/tnA(ii,jj)
+ tE(ii,jj) = tsumA2(ii,jj)-tnA(ii,jj)*mean**2
+ tBM(ii,jj) = mean
+ else
+ tE(ii,jj) = E(ii,jj)
+ tBM(ii,jj) = BM(ii,jj)
+ end if
+
+ terr = terr + tE(ii,jj)
+ end do
+ end do
+
+ if(terr.lt.berr) then
+! call intpr("Switch", -1, 2, 1)
+ call dblepr("terr", -1, terr, 1)
+ call dblepr("berr", -1, berr, 1)
+ call dblepr("diff", -1, berr-terr, 1)
+ imp = .TRUE.
+ berr=terr
+ do jj = 1, n2
+ bclu2(jj)=clu2(jj)
+ end do
+ bclu2(j) = newiclu
+ bclu2(j2) = oldiclu
+
+ do jj = 1, k2
+ bnclu2(jj) = 0
+ do ii = 1, k1
+ bnA(ii,jj) = tnA(ii,jj)
+ bsumA(ii,jj) = tsumA(ii,jj)
+ bsumA2(ii,jj) = tsumA2(ii,jj)
+ bE(ii,jj) = tE(ii,jj)
+ bBM(ii,jj) = tBM(ii,jj)
+ end do
+ end do
+
+ nbest = 1
+ do jj = 1, n2
+ bnclu2(bclu2(jj)) = bnclu2(bclu2(jj)) + 1
+ cluM2(nbest,jj) = bclu2(jj)
+ end do
+
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ bclu1(ii)=clu1(ii)
+ end do
+ do ii = 1, k1
+ bnclu1(ii)=nclu1(ii)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ cluM2(nbest,j) = newiclu
+ cluM2(nbest,j2) = oldiclu
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ end do
+ endif
+ end if
+ end if
+ end if
+ end if
+ end do
+ end do
+
+
+
+
+ err=berr
+ do i = 1, n1
+ clu1(i)=bclu1(i)
+ end do
+ do i = 1, n2
+ clu2(i)=bclu2(i)
+ end do
+
+ do i = 1, k2
+ nclu2(i) = bnclu2(i)
+ end do
+
+ do i = 1, k1
+ nclu1(i) = bnclu1(i)
+ do j = 1, k2
+ nA(i,j) = bnA(i,j)
+ sumA(i,j) = bsumA(i,j)
+ sumA2(i,j) = bsumA2(i,j)
+ E(i,j) = bE(i,j)
+ BM(i,j) = bBM(i,j)
+ end do
+ end do
+ if (printIter .OR. (iter.GT.(maxiter-10))) then
+ call intpr("iter", -1, iter, 1)
+ call intpr("nclu1", -1, nclu1, k1)
+ call intpr("clu1", -1, clu1, n1)
+ call intpr("nclu2", -1, nclu2, k2)
+ call intpr("clu2", -1, clu2, n2)
+ call intpr("nA", -1, nA, k1*k2)
+ call dblepr("err", -1, err, 1)
+ call dblepr("terr", -1, terr, 1)
+ call dblepr("berr", -1, berr, 1)
+ call dblepr("sumA", -1, sumA, k1*k2)
+ call dblepr("sumA2", -1, sumA2, k1*k2)
+ call intpr("nA", -1, nA, k1*k2)
+ end if
+ enddo
+
+! call intpr("nAD", -1, nAD, k)
+! call dblepr("sumAD", -1, sumAD, k)
+! call dblepr("sumAD2", -1, sumAD2, k)
+! call intpr("nA", -1, nA, k*k)
+! call dblepr("sumA", -1, sumA, k*k)
+! call dblepr("sumA2", -1, sumA2, k*k)
+end
+
+
diff --git a/src/opt_par_ss_com_twoMode_forMoreRel.f90 b/src/opt_par_ss_com_twoMode_forMoreRel.f90
new file mode 100644
index 0000000..64f006b
--- /dev/null
+++ b/src/opt_par_ss_com_twoMode_forMoreRel.f90
@@ -0,0 +1,579 @@
+subroutine optparsscomtmmorerel(M,clu1,clu2,maxiter,nr,n1,n2,k1,k2,err,E,BM,cluM1,cluM2,nbest,iter,printIter)
+ INTEGER iter, maxiter, nr,n1, n2, clu1, clu2, nclu1, nclu2, bnclu1, bnclu2, iclu, k1, k2,l
+ INTEGER nbest, nA, tnA, bnA, bclu1, bclu2, oldiclu, newiclu, cluM1, cluM2, i,i2, j, ii, jj, ll
+ DOUBLE PRECISION M, E, BM, err, mean, sumA, sumA2, tsumA, tsumA2, tE, tBM, terr, bsumA, bsumA2, bE, bBM, berr
+ LOGICAL imp, printIter
+ DIMENSION M(n1,n2,nr), clu1(n1), clu2(n2), E(k1,k2), BM(k1,k2,nr), cluM1(50,n1), cluM2(50,n2), sumA(k1,k2,nr), sumA2(k1,k2,nr)
+ DIMENSION nA(k1,k2), tE(k1,k2), tBM(k1,k2,nr), tsumA(k1,k2,nr), tsumA2(k1,k2,nr),tnA(k1,k2), bE(k1,k2), bBM(k1,k2,nr)
+ DIMENSION bclu1(n1), bclu2(n2), bsumA(k1,k2,nr), bsumA2(k1,k2,nr), bnA(k1,k2)
+ DIMENSION nclu1(k1), nclu2(k2), bnclu1(k1), bnclu2(k2)
+
+ do i = 1, k2
+ nclu2(i) = 0
+ end do
+
+ do i = 1, k1
+ nclu1(i) = 0
+ do j = 1, k2
+ nA(i,j) = 0
+ do l = 1, nr
+ sumA(i,j,l) = 0.0
+ sumA2(i,j,l) = 0.0
+ end do
+ end do
+ end do
+
+ do i = 1, n2
+ nclu2(clu2(i)) = nclu2(clu2(i)) + 1
+ end do
+
+ do i = 1, n1
+ nclu1(clu1(i)) = nclu1(clu1(i)) + 1
+ do j = 1, n2
+ nA(clu1(i),clu2(j)) = nA(clu1(i),clu2(j)) + 1
+ do l = 1, nr
+ sumA(clu1(i),clu2(j),l) = sumA(clu1(i),clu2(j),l)+M(i,j,l)
+ sumA2(clu1(i),clu2(j),l) = sumA2(clu1(i),clu2(j),l)+M(i,j,l)**2
+ end do
+ end do
+ end do
+
+
+ err = 0.0
+
+ do i = 1, k1
+ do j = 1, k2
+ E(i,j)=0.0
+ do l = 1, nr
+ mean = sumA(i,j,l)/nA(i,j)
+ E(i,j) = E(i,j) + sumA2(i,j,l)-nA(i,j)*mean**2
+ BM(i,j,l) = mean
+ end do
+ err = err + E(i,j)
+ end do
+ end do
+
+ nbest = 1
+ berr=err
+ do i = 1, n1
+ bclu1(i)=clu1(i)
+ cluM1(nbest,i) = clu1(i)
+ end do
+ do i = 1, n2
+ bclu2(i)=clu2(i)
+ cluM2(nbest,i) = clu2(i)
+ end do
+
+ do i = 1, k2
+ bnclu2(i) = nclu2(i)
+ end do
+
+ do i = 1, k1
+ bnclu1(i) = nclu1(i)
+ do j = 1, k2
+ bnA(i,j) = nA(i,j)
+ do l = 1,nr
+ bsumA(i,j,l) = sumA(i,j,l)
+ bsumA2(i,j,l) = sumA2(i,j,l)
+ bBM(i,j,l)=BM(i,j,l)
+ end do
+ bE(i,j)=E(i,j)
+ end do
+ end do
+
+ imp = .TRUE.
+ iter = 0
+
+ if (printIter) then
+ call intpr("iter", -1, iter, 1)
+ call intpr("nclu1", -1, nclu1, k1)
+ call intpr("clu1", -1, clu1, n1)
+ call intpr("nclu2", -1, nclu2, k2)
+ call intpr("clu2", -1, clu2, n2)
+ call dblepr("err", -1, err, 1)
+ call dblepr("sumA", -1, sumA, k1*k2*nr)
+ call dblepr("sumA2", -1, sumA2, k1*k2*nr)
+
+ end if
+
+ do while (imp .AND. (iter .LT. maxiter))
+ imp = .FALSE.
+ iter = iter + 1
+
+ do i = 1, n1
+ oldiclu=clu1(i)
+ if(nclu1(oldiclu).gt.1) then
+ do iclu = 1, k1
+ if(oldiclu.ne.iclu) then
+ newiclu = iclu
+
+ do ii = 1, k1
+ do jj = 1, k2
+ tnA(ii,jj) = nA(ii,jj)
+ do ll = 1, nr
+ tsumA(ii,jj,ll) = sumA(ii,jj,ll)
+ tsumA2(ii,jj,ll) = sumA2(ii,jj,ll)
+ end do
+ end do
+ end do
+
+ do jj = 1, k2
+ tnA(oldiclu,jj) = tnA(oldiclu,jj) - nclu2(jj)
+ tnA(newiclu,jj) = tnA(newiclu,jj) + nclu2(jj)
+ end do
+
+ do j = 1 ,n2
+ do l = 1, nr
+ tsumA(oldiclu,clu2(j),l) = tsumA(oldiclu,clu2(j),l) - M(i,j,l)
+ tsumA(newiclu,clu2(j),l) = tsumA(newiclu,clu2(j),l) + M(i,j,l)
+ tsumA2(oldiclu,clu2(j),l) = tsumA2(oldiclu,clu2(j),l) - M(i,j,l)**2
+ tsumA2(newiclu,clu2(j),l) = tsumA2(newiclu,clu2(j),l) + M(i,j,l)**2
+ end do
+ end do
+
+
+ terr = 0.0
+
+ do ii = 1, k1
+ do jj = 1, k2
+ if(ii.eq.newiclu .or. ii.eq.oldiclu) then
+ tE(ii,jj) = 0
+ do ll = 1, nr
+ mean = tsumA(ii,jj,ll)/tnA(ii,jj)
+ tE(ii,jj) = tE(ii,jj) + tsumA2(ii,jj,ll)-tnA(ii,jj)*mean**2
+ tBM(ii,jj,ll) = mean
+ end do
+ else
+ do ll = 1, nr
+ tBM(ii,jj,ll) = BM(ii,jj,ll)
+ end do
+ tE(ii,jj) = E(ii,jj)
+
+ end if
+
+ terr = terr + tE(ii,jj)
+ end do
+ end do
+ if (terr.lt.berr) then
+! call intpr("Move", -1, 1, 1)
+ imp = .TRUE.
+ berr=terr
+ do ii = 1, n1
+ bclu1(ii)=clu1(ii)
+ end do
+
+ do ii = 1, k1
+ bnclu1(ii) = 0
+ do jj = 1, k2
+ bnA(ii,jj) = tnA(ii,jj)
+ bE(ii,jj)=tE(ii,jj)
+ do ll = 1, nr
+ bsumA(ii,jj,ll) = tsumA(ii,jj,ll)
+ bsumA2(ii,jj,ll) = tsumA2(ii,jj,ll)
+ bBM(ii,jj,ll)=tBM(ii,jj,ll)
+ end do
+ end do
+ end do
+
+ bclu1(i) = newiclu
+
+ nbest = 1
+ do ii = 1, n1
+ bnclu1(bclu1(ii)) = bnclu1(bclu1(ii)) + 1
+ cluM1(nbest,ii) = bclu1(ii)
+ end do
+
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ end do
+ cluM1(nbest,i) = newiclu
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ endif
+ end if
+ end if
+
+ end if
+ end do
+ end if
+
+ do i2 = 1, i - 1
+ if(i.ne.i2) then
+ if(clu1(i).ne.clu1(i2)) then
+ !tclu = clu
+ !tclu(i) = clu(j)
+ !tclu(j) = clu(i)
+ newiclu = clu1(i2)
+
+ do ii = 1, k1
+ do jj = 1, k2
+ tnA(ii,jj) = nA(ii,jj)
+ do ll = 1, nr
+ tsumA(ii,jj,ll) = sumA(ii,jj,ll)
+ tsumA2(ii,jj,ll) = sumA2(ii,jj,ll)
+ end do
+ end do
+ end do
+
+ do jj = 1, n2
+ do ll = 1, nr
+ tsumA(oldiclu,clu2(jj),ll) = tsumA(oldiclu,clu2(jj),ll) - M(i,jj,ll) + M(i2,jj,ll)
+ tsumA(newiclu,clu2(jj),ll) = tsumA(newiclu,clu2(jj),ll) + M(i,jj,ll) - M(i2,jj,ll)
+ tsumA2(oldiclu,clu2(jj),ll) = tsumA2(oldiclu,clu2(jj),ll) - M(i,jj,ll)**2 + M(i2,jj,ll)**2
+ tsumA2(newiclu,clu2(jj),ll) = tsumA2(newiclu,clu2(jj),ll) + M(i,jj,ll)**2 - M(i2,jj,ll)**2
+ end do
+ end do
+
+
+ terr = 0.0
+
+ do ii = 1, k1
+ do jj = 1, k2
+ if(ii.eq.newiclu .or. ii.eq.oldiclu) then
+ tE(ii,jj) = 0.0
+ do ll = 1, nr
+ mean = tsumA(ii,jj,ll)/tnA(ii,jj)
+ tE(ii,jj) = tE(ii,jj) + tsumA2(ii,jj,ll)-tnA(ii,jj)*mean**2
+ tBM(ii,jj,ll) = mean
+ end do
+ else
+ tE(ii,jj) = E(ii,jj)
+ do ll = 1, nr
+ tBM(ii,jj,ll) = BM(ii,jj,ll)
+ end do
+ end if
+
+ terr = terr + tE(ii,jj)
+ end do
+ end do
+
+
+ if(terr.lt.berr)then
+! call intpr("Switch", -1, 2, 1)
+ imp = .TRUE.
+ berr=terr
+ do ii = 1, n1
+ bclu1(ii)=clu1(ii)
+ end do
+ bclu1(i) = newiclu
+ bclu1(i2) = oldiclu
+
+ do ii = 1, k1
+ bnclu1(ii) = 0
+ do jj = 1, k2
+ bnA(ii,jj) = tnA(ii,jj)
+ do ll = 1,nr
+ bsumA(ii,jj,ll) = tsumA(ii,jj,ll)
+ bsumA2(ii,jj,ll) = tsumA2(ii,jj,ll)
+ bBM(ii,jj,ll) = tBM(ii,jj,ll)
+ end do
+ bE(ii,jj) = tE(ii,jj)
+ end do
+ end do
+
+ nbest = 1
+ do ii = 1, n1
+ bnclu1(bclu1(ii)) = bnclu1(bclu1(ii)) + 1
+ cluM1(nbest,ii) = bclu1(ii)
+ end do
+
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ end do
+ cluM1(nbest,i) = newiclu
+ cluM1(nbest,i2) = oldiclu
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ endif
+ end if
+ end if
+ end if
+ end if
+ end do
+ end do
+
+
+ do j = 1, n2
+ oldiclu=clu2(j)
+ if(nclu2(oldiclu).gt.1) then
+ do iclu = 1, k2
+ if(oldiclu.ne.iclu) then
+ newiclu = iclu
+
+ do ii = 1, k1
+ do jj = 1, k2
+ tnA(ii,jj) = nA(ii,jj)
+ do ll = 1, nr
+ tsumA(ii,jj,ll) = sumA(ii,jj,ll)
+ tsumA2(ii,jj,ll) = sumA2(ii,jj,ll)
+ end do
+ end do
+ end do
+
+ do ii = 1, k1
+ tnA(ii,oldiclu) = tnA(ii,oldiclu) - nclu1(ii)
+ tnA(ii,newiclu) = tnA(ii,newiclu) + nclu1(ii)
+ end do
+
+ do i = 1 ,n1
+ do l = 1, nr
+ tsumA(clu1(i),oldiclu,l) = tsumA(clu1(i),oldiclu,l) - M(i,j,l)
+ tsumA(clu1(i),newiclu,l) = tsumA(clu1(i),newiclu,l) + M(i,j,l)
+ tsumA2(clu1(i),oldiclu,l) = tsumA2(clu1(i),oldiclu,l) - M(i,j,l)**2
+ tsumA2(clu1(i),newiclu,l) = tsumA2(clu1(i),newiclu,l) + M(i,j,l)**2
+ end do
+ end do
+
+
+ terr = 0.0
+
+ do ii = 1, k1
+ do jj = 1, k2
+ if(jj.eq.newiclu .or. jj.eq.oldiclu) then
+ tE(ii,jj) = 0.0
+ do ll = 1, nr
+ mean = tsumA(ii,jj,ll)/tnA(ii,jj)
+ tE(ii,jj) = tE(ii,jj) + tsumA2(ii,jj,ll)-tnA(ii,jj)*mean**2
+ tBM(ii,jj,ll) = mean
+ end do
+ else
+ tE(ii,jj) = E(ii,jj)
+ do ll = 1, nr
+ tBM(ii,jj,ll) = BM(ii,jj,ll)
+ end do
+ end if
+
+ terr = terr + tE(ii,jj)
+ end do
+ end do
+
+ if (terr.lt.berr) then
+! call intpr("Move", -1, 1, 1)
+ imp = .TRUE.
+ berr=terr
+ do jj = 1, n2
+ bclu2(jj)=clu2(jj)
+ end do
+
+ do jj = 1, k2
+ bnclu2(jj) = 0
+ do ii = 1, k1
+ bnA(ii,jj) = tnA(ii,jj)
+ do ll = 1, nr
+ bsumA(ii,jj,ll) = tsumA(ii,jj,ll)
+ bsumA2(ii,jj,ll) = tsumA2(ii,jj,ll)
+ bBM(ii,jj,ll)=tBM(ii,jj,ll)
+ end do
+ bE(ii,jj)=tE(ii,jj)
+ end do
+ end do
+
+ bclu2(j) = newiclu
+
+ nbest = 1
+ do jj = 1, n2
+ bnclu2(bclu2(jj)) = bnclu2(bclu2(jj)) + 1
+ cluM2(nbest,jj) = bclu2(jj)
+ end do
+
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ bclu1(ii)=clu1(ii)
+ end do
+ do ii = 1, k1
+ bnclu1(ii)=nclu1(ii)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ cluM2(nbest,j) = newiclu
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ end do
+ endif
+ end if
+ end if
+
+ end if
+ end do
+ end if
+
+ do j2 = 1, j - 1
+ if(j.ne.j2) then
+ if(clu2(j).ne.clu2(j2)) then
+ !tclu = clu
+ !tclu(i) = clu(j)
+ !tclu(j) = clu(i)
+ newiclu = clu2(j2)
+
+ do ii = 1, k1
+ do jj = 1, k2
+ tnA(ii,jj) = nA(ii,jj)
+ do ll = 1, nr
+ tsumA(ii,jj,ll) = sumA(ii,jj,ll)
+ tsumA2(ii,jj,ll) = sumA2(ii,jj,ll)
+ end do
+ end do
+ end do
+
+ do ii = 1, n1
+ do ll = 1, nr
+ tsumA(clu1(ii),oldiclu,ll) = tsumA(clu1(ii),oldiclu,ll) - M(ii,j,ll) + M(ii,j2,ll)
+ tsumA(clu1(ii),newiclu,ll) = tsumA(clu1(ii),newiclu,ll) + M(ii,j,ll) - M(ii,j2,ll)
+ tsumA2(clu1(ii),oldiclu,ll) = tsumA2(clu1(ii),oldiclu,ll) - M(ii,j,ll)**2 + M(ii,j2,ll)**2
+ tsumA2(clu1(ii),newiclu,ll) = tsumA2(clu1(ii),newiclu,ll) + M(ii,j,ll)**2 - M(ii,j2,ll)**2
+ end do
+ end do
+
+
+ terr = 0.0
+
+ do ii = 1, k1
+ do jj = 1, k2
+ if(jj.eq.newiclu .or. jj.eq.oldiclu) then
+ tE(ii,jj) = 0.0
+ do ll = 1, nr
+ mean = tsumA(ii,jj,ll)/tnA(ii,jj)
+ tE(ii,jj) = tE(ii,jj) + tsumA2(ii,jj,ll)-tnA(ii,jj)*mean**2
+ tBM(ii,jj,ll) = mean
+ end do
+ else
+ tE(ii,jj) = E(ii,jj)
+ do ll = i,nr
+ tBM(ii,jj,ll) = BM(ii,jj,ll)
+ end do
+ end if
+
+ terr = terr + tE(ii,jj)
+ end do
+ end do
+
+
+ if(terr.lt.berr)then
+! call intpr("Switch", -1, 2, 1)
+ imp = .TRUE.
+ berr=terr
+ do jj = 1, n2
+ bclu2(jj)=clu2(jj)
+ end do
+ bclu2(j) = newiclu
+ bclu2(j2) = oldiclu
+
+ do jj = 1, k2
+ bnclu2(jj) = 0
+ do ii = 1, k1
+ bnA(ii,jj) = tnA(ii,jj)
+ do ll = 1, nr
+ bsumA(ii,jj,ll) = tsumA(ii,jj,ll)
+ bsumA2(ii,jj,ll) = tsumA2(ii,jj,ll)
+ bBM(ii,jj,ll) = tBM(ii,jj,ll)
+ end do
+ bE(ii,jj) = tE(ii,jj)
+ end do
+ end do
+
+ nbest = 1
+ do jj = 1, n2
+ bnclu2(bclu2(jj)) = bnclu2(bclu2(jj)) + 1
+ cluM2(nbest,jj) = bclu2(jj)
+ end do
+
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ bclu1(ii)=clu1(ii)
+ end do
+
+ do ii = 1, k1
+ bnclu1(ii)=nclu1(ii)
+ end do
+ else
+ if(terr.eq.berr)then
+ nbest = nbest + 1
+ if(nbest.le.50) then
+ do jj = 1, n2
+ cluM2(nbest,jj) = clu2(jj)
+ end do
+ cluM2(nbest,j) = newiclu
+ cluM2(nbest,j2) = oldiclu
+ do ii = 1, n1
+ cluM1(nbest,ii) = clu1(ii)
+ end do
+ endif
+ end if
+ end if
+ end if
+ end if
+ end do
+ end do
+
+
+
+
+ err=berr
+ do i = 1, n1
+ clu1(i)=bclu1(i)
+ end do
+ do i = 1, n2
+ clu2(i)=bclu2(i)
+ end do
+
+ do i = 1, k2
+ nclu2(i) = bnclu2(i)
+ end do
+
+ do i = 1, k1
+ nclu1(i) = bnclu1(i)
+ do j = 1, k2
+ nA(i,j) = bnA(i,j)
+ do l = 1, nr
+ sumA(i,j,l) = bsumA(i,j,l)
+ sumA2(i,j,l) = bsumA2(i,j,l)
+ BM(i,j,l) = bBM(i,j,l)
+ end do
+ E(i,j) = bE(i,j)
+ end do
+ end do
+ if (printIter) then
+ call intpr("iter", -1, iter, 1)
+ call intpr("nclu1", -1, nclu1, k1)
+ call intpr("clu1", -1, clu1, n1)
+ call intpr("nclu2", -1, nclu2, k2)
+ call intpr("clu2", -1, clu2, n2)
+ call intpr("nA", -1, nA, k1*k2)
+ call dblepr("err", -1, err, 1)
+ call dblepr("sumA", -1, sumA, k1*k2*nr)
+ call dblepr("sumA2", -1, sumA2, k1*k2*nr)
+ call intpr("nA", -1, nA, k1*k2)
+ end if
+ enddo
+
+! call intpr("nAD", -1, nAD, k)
+! call dblepr("sumAD", -1, sumAD, k)
+! call dblepr("sumAD2", -1, sumAD2, k)
+! call intpr("nA", -1, nA, k*k)
+! call dblepr("sumA", -1, sumA, k*k)
+! call dblepr("sumA2", -1, sumA2, k*k)
+end
+!!! popravljeno do tu
+
+
diff --git a/src/ss_blocks.f90 b/src/ss_blocks.f90
new file mode 100644
index 0000000..5118872
--- /dev/null
+++ b/src/ss_blocks.f90
@@ -0,0 +1,106 @@
+subroutine critfunsscom(M,n,clu,k,diag,err,E,BM)
+ INTEGER n, clu, k, i, j, nA, nAD
+ DOUBLE PRECISION M, E, BM, sumA, sumAD, sumA2, sumAD2, err, mean
+ LOGICAL diag
+ DIMENSION M(n,n), clu(n), E(k,k), BM(k,k), sumA(k,k), sumAD(k),sumA2(k,k), sumAD2(k), nA(k,k), nAD(k)
+
+ do i = 1, k
+ nAD(i) = 0
+ sumAD(i) = 0.0
+ sumAD2(i) = 0.0
+ do j = 1, k
+ nA(i,j) = 0
+ sumA(i,j) = 0.0
+ sumA2(i,j) = 0.0
+ end do
+ end do
+
+
+ do i = 1, n
+ do j = 1, n
+ if((.not.diag) .or. (i.ne.j)) then
+ nA(clu(i),clu(j)) = nA(clu(i),clu(j)) + 1
+ sumA(clu(i),clu(j)) = sumA(clu(i),clu(j))+M(i,j)
+ sumA2(clu(i),clu(j)) = sumA2(clu(i),clu(j))+M(i,j)**2
+ else
+ nAD(clu(i)) = nAD(clu(i)) + 1
+ sumAD(clu(i)) = sumAD(clu(i))+M(i,i)
+ sumAD2(clu(i)) = sumAD2(clu(i))+M(i,i)**2
+ endif
+ end do
+ end do
+
+ err = 0.0
+
+ do i = 1, k
+ do j = 1, k
+ if(diag.and.i.eq.j) then
+ if(nA(i,j).eq.0) then
+ nA(i,j) = 1
+ end if
+ mean = sumA(i,j)/nA(i,j)
+ E(i,j) = sumA2(i,j)-nA(i,j)*mean**2 + sumAD2(i)-sumAD(i)**2/nAD(i)
+ BM(i,j) = mean
+ err = err + E(i,j)
+ else
+ mean = sumA(i,j)/nA(i,j)
+ E(i,j) = sumA2(i,j)-nA(i,j)*mean**2
+ BM(i,j) = mean
+ err = err + E(i,j)
+ endif
+ end do
+ end do
+end
+
+
+
+
+
+
+
+
+
+
+
+subroutine sscom(B,n1,n2,diag,sserr,mean)
+ INTEGER n1, n2, ia, iad
+ DOUBLE PRECISION B, A, AD, ss, sserr, mean, temp
+ LOGICAL diag
+ DIMENSION B(n1,n2), A(n1*n2), AD(n1)
+
+ ia = 0
+ iad = 0
+ do i=1, n1
+ do j=1, n2
+ if(.not.diag.or.i.ne.j) then
+ ia = ia + 1
+ A(ia) = B(i,j)
+ else
+ iad = iad + 1
+ AD(iad) = B(i,j)
+ endif
+ end do
+ end do
+
+ if(diag) then
+ sserr = ss(A,n1*(n1-1),mean) + ss(AD,n1,temp)
+ else
+ sserr = ss(A,n1*n2,mean)
+ endif
+end
+
+DOUBLE PRECISION FUNCTION ss(a,n,m)
+ INTEGER n, i
+ DOUBLE PRECISION a, s, m
+ DIMENSION a(n)
+ s = 0.0
+ do i=1, n
+ s = s + a(i)
+ end do
+ m = s / n
+ ss = 0.0
+ do i=1, n
+ ss = ss + (a(i)-m)**2
+ end do
+end
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-blockmodeler.git
More information about the debian-med-commit
mailing list