blockmodeling/0000755000175100001440000000000011323147746013111 5ustar hornikusersblockmodeling/NAMESPACE0000644000175100001440000000241611204536144014323 0ustar hornikusersuseDynLib(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) blockmodeling/CHANGES0000644000175100001440000001043211320333335014070 0ustar hornikusersName: 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 and 10) as compiting block types. 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” blockmodeling/man/0000755000175100001440000000000011323147746013664 5ustar hornikusersblockmodeling/man/opt.random.par.Rd0000644000175100001440000002623611320333335017012 0ustar hornikusers\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 function \code{parOK} to allow only certain kinds of partitions), 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{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 blockmodeling/man/find.m.Rd0000644000175100001440000000753111110224010015302 0ustar hornikusers\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 blockmodeling/man/plot.mat.Rd0000644000175100001440000002312711110224010015664 0ustar hornikusers\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 blockmodeling/man/crit.fun.Rd0000644000175100001440000003011611110270510015660 0ustar hornikusers\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 can be a list of such arrays.\cr\cr \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 the allowed blocks in at least one block and \code{TRUE} otherwise.\cr\cr \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 blockmodeling/man/clu.Rd0000644000175100001440000000574511110224010014717 0ustar hornikusers\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 blockmodeling/man/Pajek.Rd0000644000175100001440000001064311320333335015175 0ustar hornikusers\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 blockmodeling/man/ircNorm.Rd0000644000175100001440000000241111110224010015530 0ustar hornikusers\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} blockmodeling/man/opt.par.Rd0000644000175100001440000001754711320333335015540 0ustar hornikusers\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 function \code{parOK} to allow only certain kinds of partitions), 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{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 blockmodeling/man/sedist.Rd0000644000175100001440000000630311320333335015434 0ustar hornikusers\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 blockmodeling/man/two2one.Rd0000644000175100001440000000406211110224010015520 0ustar hornikusers\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 blockmodeling/man/blockmodeling-package.Rd0000644000175100001440000000725611110224010020335 0ustar hornikusers\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)) } blockmodeling/man/genRandomPar.Rd0000644000175100001440000000373311110224010016504 0ustar hornikusers\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} blockmodeling/man/gplot1.Rd0000644000175100001440000000527711110270510015350 0ustar hornikusers\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 blockmodeling/man/nkpartitions.Rd0000644000175100001440000000330311110224010016645 0ustar hornikusers\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 blockmodeling/man/reorderImage.Rd0000644000175100001440000000321611110224010016530 0ustar hornikusers\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 blockmodeling/man/check.these.par.Rd0000644000175100001440000001071611110224010017073 0ustar hornikusers\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 blockmodeling/man/formatA.Rd0000644000175100001440000000161111110224010015511 0ustar hornikusers\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 blockmodeling/man/REGE.Rd0000644000175100001440000001341411110224010014646 0ustar hornikusers\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 blockmodeling/man/ss.Rd0000644000175100001440000000111011110224010014537 0ustar hornikusers\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 blockmodeling/man/fun.by.blocks.Rd0000644000175100001440000000710111110224010016575 0ustar hornikusers\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 blockmodeling/man/rand.Rd0000644000175100001440000000167611110224010015057 0ustar hornikusers\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 blockmodeling/man/recode.Rd0000644000175100001440000000115611110224010015365 0ustar hornikusers\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 blockmodeling/DESCRIPTION0000644000175100001440000000144411323365067014620 0ustar hornikusersPackage: 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 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 blockmodeling/src/0000755000175100001440000000000011323147746013700 5ustar hornikusersblockmodeling/src/opt_par_ss_com_twoMode.f900000644000175100001440000003045711110271142020714 0ustar hornikuserssubroutine 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 blockmodeling/src/REGE_NM_DIAG_R.f900000644000175100001440000000420211110271142016355 0ustar hornikusers! 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 blockmodeling/src/opt_par_ss_com.f900000644000175100001440000002351111144067215017222 0ustar hornikuserssubroutine 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 blockmodeling/src/REGE_NM_R.f900000644000175100001440000000376111110271142015602 0ustar hornikusers! 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 blockmodeling/src/opt_par_ss_com_twoMode_forMoreRel.f900000644000175100001440000003302511110271142023042 0ustar hornikuserssubroutine 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 blockmodeling/src/REGE_OW_R.f900000644000175100001440000000443711110271142015616 0ustar hornikusers! 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 blockmodeling/src/ss_blocks.f900000644000175100001440000000361611110271142016166 0ustar hornikuserssubroutine 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 blockmodeling/src/REGE_NM_NE_R.f900000644000175100001440000000544111110271142016161 0ustar hornikusers! 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 blockmodeling/src/REGE_OW_NE_R.f900000644000175100001440000000601211110271142016167 0ustar hornikusers! 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 blockmodeling/src/REGE_OWNM_NE_R.f900000644000175100001440000000577411110271142016440 0ustar hornikusers! 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 blockmodeling/src/REGD_OW_R.f900000644000175100001440000000562011110271142015610 0ustar hornikusers! 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 blockmodeling/src/REGE_OWNM_DIAG_R.f900000644000175100001440000000453311110271142016632 0ustar hornikusers! 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 blockmodeling/src/REGD_R.f900000644000175100001440000000453211110271142015204 0ustar hornikusers! 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 blockmodeling/src/REGE_OWNM_R.f900000644000175100001440000000431111110271142016040 0ustar hornikusers! 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 blockmodeling/src/REGE_NE_R.f900000644000175100001440000000547711110271142015600 0ustar hornikusers! 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 blockmodeling/src/REGD_OW_NE_R.f900000644000175100001440000000673511110271142016202 0ustar hornikusers! 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 blockmodeling/src/REGE_R.f900000644000175100001440000000374611110271142015213 0ustar hornikusers! 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 blockmodeling/src/REGD_NE_R.f900000644000175100001440000000560611110271142015571 0ustar hornikusers! 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 blockmodeling/R/0000755000175100001440000000000011323147746013312 5ustar hornikusersblockmodeling/R/loadmatrix.R0000644000175100001440000000133411110224010015550 0ustar hornikusers"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") blockmodeling/R/formatA.R0000644000175100001440000000014611106601760015015 0ustar hornikusers"formatA" <- function(x,digits=2, FUN=round,...){ noquote(format(FUN(x, digits=digits),...)) } blockmodeling/R/fun.by.blocks.R0000644000175100001440000000010311106601760016072 0ustar hornikusers"fun.by.blocks" <- function(x, ...) UseMethod("fun.by.blocks") blockmodeling/R/err.R0000644000175100001440000000006711106601760014216 0ustar hornikusers"err" <- function(res,...){ res$best[[1]]$err } blockmodeling/R/loadvector.R0000644000175100001440000000031411106601760015563 0ustar hornikusers"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") blockmodeling/R/savecluster.R0000644000175100001440000000040711204536144015766 0ustar hornikusers"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") blockmodeling/R/nkpartitions.R0000644000175100001440000000343711106601760016157 0ustar hornikusers"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 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) } } } blockmodeling/R/ircNorm.R0000644000175100001440000000104411106601760015033 0ustar hornikusersircNorm<-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)=maxiter){ warning("Maximum number of itrerations (",maxiter,") reached, convergence not achieved.\n") break } } M<-(tmpM[[1]]+tmpM[[2]])/2 return(M) }blockmodeling/R/mean.max.col.R0000644000175100001440000000007611106601760015706 0ustar hornikusers"mean.max.col" <- function(x,...)mean(apply(x,2,max,...)) blockmodeling/R/plot.opt.more.par.R0000644000175100001440000000104311106601760016722 0ustar hornikusers"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,...) } blockmodeling/R/REGE.ow.R0000644000175100001440000000253611106601760014577 0ustar hornikusers"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)) } blockmodeling/R/loadpajek.R0000644000175100001440000000447111110224010015343 0ustar hornikusersloadpajek<-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) } blockmodeling/R/savematrix.R0000644000175100001440000000364411204536144015617 0ustar hornikusers"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)") blockmodeling/R/gen.opt.par.R0000644000175100001440000003230211225710705015560 0ustar hornikusers"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((iter1)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$err1) "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(i11) "[[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$err1) "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=""))) } blockmodeling/R/plot.opt.par.mode.R0000644000175100001440000000104311106601760016704 0ustar hornikusers"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,...) } blockmodeling/R/plot.check.these.par.R0000644000175100001440000000105211106601760017343 0ustar hornikusers"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,...) } blockmodeling/R/crand.R0000644000175100001440000000041711106601760014514 0ustar hornikusers"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)) } blockmodeling/R/REGE.FC.R0000644000175100001440000000411111106601760014431 0ustar hornikusers"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)) } blockmodeling/R/plot.opt.more.par.mode.R0000644000175100001440000000105011106601760017643 0ustar hornikusers"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,...) } blockmodeling/R/usepos.R0000644000175100001440000000005311106601760014737 0ustar hornikusers"usepos" <- function(x)ifelse(x>0,x,0) blockmodeling/R/find.cut.R0000644000175100001440000000221111106601760015131 0ustar hornikusers"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) } blockmodeling/R/sumpos.R0000644000175100001440000000005111106601760014745 0ustar hornikusers"sumpos" <- function(v){sum(v[v>0])} blockmodeling/R/IM.R0000644000175100001440000000010111106601760013720 0ustar hornikusers"IM" <- function(res,which=1,...){ res$best[[which]]$IM } blockmodeling/R/plot.mat.R0000644000175100001440000002472211320333335015166 0ustar hornikusers"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=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) } blockmodeling/R/fun.by.blocks.opt.more.par.R0000644000175100001440000000060711106601760020426 0ustar hornikusers"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),...) } blockmodeling/R/opt.random.par.R0000644000175100001440000001565311225710705016301 0ustar hornikusers"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 } } blockmodeling/R/gen.crit.fun.R0000644000175100001440000010626411227106526015740 0ustar hornikusers"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("[sr0)\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("[sc0)\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(nr1)"if(nc1)"if(nc1)"if(nr1)"if(nc1)"if(nr1)"if(nc1) c("if(nr1) c("if(nc1)"if(nc1)"if(nr1)"if(nc1)"if(nr1)"if(nc=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(nc1)"if(nr1)"if(nc1)"if(nr1)"if(nc1)"if(nr1)"if(nr1)"if(nc1)"if(nc1)"if(nr1)"if(nc=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(nc1)"if(nr1)"if(nc=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(nr1)"if(nc=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=""))) } } } blockmodeling/R/fun.by.blocks.default.R0000644000175100001440000000163411110224010017507 0ustar hornikusers"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) } blockmodeling/R/genRandomPar.R0000644000175100001440000000456411106601760016011 0ustar hornikusers"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) } blockmodeling/R/savevector.R0000644000175100001440000000044611204536144015612 0ustar hornikusers"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") blockmodeling/R/crit.fun.R0000644000175100001440000000462511106601760015162 0ustar hornikusers"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) } blockmodeling/R/loadvector2.R0000644000175100001440000000052711110224010015633 0ustar hornikusers"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") blockmodeling/R/meanpos.R0000644000175100001440000000005311106601760015063 0ustar hornikusers"meanpos" <- function(v){mean(v[v>0])} blockmodeling/R/crand2.R0000644000175100001440000000046111106601760014575 0ustar hornikusers"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)) } blockmodeling/R/gplot.R0000644000175100001440000000231611106601760014552 0ustar hornikusers"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=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) } blockmodeling/R/one2two.R0000644000175100001440000000061111106601760015016 0ustar hornikusers"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)) } blockmodeling/R/rand2.R0000644000175100001440000000025211106601760014430 0ustar hornikusers"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) } blockmodeling/R/savepajek.R0000644000175100001440000000526111204536144015402 0ustar hornikuserssavepajek<-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) } } } blockmodeling/R/REGE_for.R0000644000175100001440000003705011110224010015000 0ustar hornikusersREGE.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)) } blockmodeling/R/two2one.R0000644000175100001440000000056711106601760015030 0ustar hornikusers"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)) } blockmodeling/R/reorderImage.R0000644000175100001440000000035411106601760016032 0ustar hornikusersreorderImage<-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]) } blockmodeling/R/plot.mat.nm.R0000644000175100001440000000150311110224010015551 0ustar hornikusers"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) }blockmodeling/R/REGE.R0000644000175100001440000000300211106601760014140 0ustar hornikusers"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)) } blockmodeling/R/plot.opt.par.R0000644000175100001440000000103611106601760015763 0ustar hornikusers"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,...) } blockmodeling/R/useneg.R0000644000175100001440000000005311106601760014707 0ustar hornikusers"useneg" <- function(x)ifelse(x<0,x,0) blockmodeling/R/recode.R0000644000175100001440000000040111106601760014657 0ustar hornikusers"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) } blockmodeling/R/loadnetwork2.R0000644000175100001440000000460711320333335016043 0ustar hornikusers"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) } blockmodeling/R/mean.max.row.R0000644000175100001440000000007611106601760015740 0ustar hornikusers"mean.max.row" <- function(x,...)mean(apply(x,1,max,...)) blockmodeling/R/plot.crit.fun.R0000644000175100001440000000034111106601760016126 0ustar hornikusers"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,...) } blockmodeling/R/find.m.R0000644000175100001440000000644211106601760014604 0ustar hornikusers"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[sr1){ 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,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)0])]<-0 if(half) m<-m/2 return(m) } blockmodeling/R/savenetwork.R0000644000175100001440000000541611204536144016003 0ustar hornikusers"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)") blockmodeling/R/opt.these.par.R0000644000175100001440000001136611320333335016122 0ustar hornikusers"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") } } blockmodeling/R/opt.par.R0000644000175100001440000000507211225710705015014 0ustar hornikusers"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,...)) } blockmodeling/R/parOKgroups.R0000644000175100001440000000031011110224010015651 0ustar hornikusers"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)) } blockmodeling/R/clu.R0000644000175100001440000000020511106601760014203 0ustar hornikusers"clu" <- function(res,which=1,...){ res$best[[which]]$clu } "partitions" <- function(res)lapply(res$best,function(x)x$clu) blockmodeling/R/nkpar.R0000644000175100001440000000025011106601760014533 0ustar hornikusers"nkpar" <- function(n, k) { # Author: Chris Andrews sum((-1)^seq(0,k-1) * choose(k, seq(0,k-1)) * (k-seq(0,k-1))^n) / factorial(k) } blockmodeling/R/find.m2.R0000644000175100001440000000240511106601760014661 0ustar hornikusers"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) } blockmodeling/R/check.these.par.R0000644000175100001440000000313411106601760016371 0ustar hornikusers"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$err0) { 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)) } blockmodeling/R/loadnetwork.R0000644000175100001440000000626411320333335015762 0ustar hornikusers"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) } blockmodeling/R/sedist.R0000644000175100001440000000667011106601760014727 0ustar hornikusers"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) } blockmodeling/R/rand.R0000644000175100001440000000022711106601760014350 0ustar hornikusers"rand" <- function (tab) #Hubert & Arabie { n <- sum(tab) 1 + (sum(tab^2) - (sum(rowSums(tab)^2) + sum(colSums(tab)^2))/2)/choose(n, 2) } blockmodeling/R/ad.R0000644000175100001440000000005511106601760014007 0ustar hornikusers"ad" <- function(x)sum(abs(x-median(x))) blockmodeling/R/ss.R0000644000175100001440000000006511106601760014051 0ustar hornikusers"ss" <- function(x){sum(x^2)-sum(x)^2/length(x)}