blockmodeling/0000755000176200001440000000000013622060220013054 5ustar liggesusersblockmodeling/NAMESPACE0000644000176200001440000000375613614037332014317 0ustar liggesusersuseDynLib(blockmodeling,.registration = TRUE) #import(foreach) import(Matrix) #import(doParallel) #import(doRNG) import(parallel) import(methods) #importFrom("sna", "gplot") #importFrom("methods", "as") importFrom("grDevices", "gray", "grey") importFrom("graphics", "mtext", "par", "plot.default", "rect", "segments", "text", "title") #importFrom("methods", "as") importFrom("stats", "as.dist", "cor", "cov", "median", "na.omit", "optimize", "runif") importFrom("utils", "citation", "read.table", "write.table") export(critFunC, optParC, optRandomParC) #basic front end functions for interface with C #export(parArr2VecC, parVec2ArrC) #experimental front end functions for interface with C #export(check.these.par, crit.fun, opt.par, opt.random.par, opt.these.par) #basic front end functions export(genRandomPar) export(plot.mat, plot.array, plotMat, plotMatNm, plotArray) #,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(genMatrixMult) export(clu, err, IM, EM, reorderImage, partitions) export(one2two, two2one) export(recode, formatA) export(fun.by.blocks) export(loadnetwork, loadnetwork2, loadnetwork3, loadnetwork4, loadmatrix, loadvector, loadvector2, savematrix, savenetwork, savevector, loadpajek) 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,crit.fun) S3method(plot,mat) S3method(plot,array) S3method(plot,opt.more.par) S3method(plot,opt.more.par.mode) S3method(plot,opt.par) S3method(plot,opt.par.mode) S3method(plot,optPar) S3method(fun.by.blocks,opt.more.par) S3method(fun.by.blocks,default) blockmodeling/data/0000755000176200001440000000000013621550333013775 5ustar liggesusersblockmodeling/data/notesBorrowing.RData0000644000176200001440000000041613620447033017735 0ustar liggesusers r0b```b`fcd`b2Y# '/I-v/*/K*dpI (Տ\Aw@.N+Ai(m&oׁ"a`샹@wV Rqf 큻h2hhS@U/,HASǁ&]8zObO54>* GI|R2d)^P yєp%Pu1]blockmodeling/man/0000755000176200001440000000000013621550334013640 5ustar liggesusersblockmodeling/man/notesBorrowing.Rd0000644000176200001440000000261013620246732017152 0ustar liggesusers\name{notesBorrowing} \alias{notesBorrowing} \docType{data} \title{ The notes borrowing network between social-informatics students } \description{ The data come from a survey conducted in May 1993 on 13 social-informatics students (Hlebec, 1996). The network was constructed from answers to the question, “How often did you borrow notes from this person?” for each of the fellow students. The respondents indicated the frequency of borrowing by choosing (on a computer) a line of length 1–20, where 1 meant no borrowing. 1 was deducted from all answers, so that 0 now means no borrowing. The data was first used for blockmodeling in Žiberna (2007). } \usage{data("notesBorrowing")} \format{ The data set is a valued matrix with 13 rows and columns. } %%\details{ %% ~~ If necessary, more details than the __description__ above ~~ %%} %%\source{ %% ~~ reference to a publication or URL from which the data were obtained ~~ %%} \references{ Hlebec, V., (1996). \emph{Metodološke značilnosti anketnega zbiranja podatkov v analizi omrežji: Magistersko delo}. FDV, Ljubljana. Žiberna, A. (2007). Generalized blockmodeling of valued networks. \emph{Social Networks}, 29, 105–126. https://doi.org/10.1016/j.socnet.2006.04.002 } \examples{ data(notesBorrowing) # Plot the network. # (The function plotMat is from blockmodeling package.) # plotMat(nyt) } \keyword{datasets} blockmodeling/man/nkpartitions.Rd0000644000176200001440000000352513370034046016657 0ustar liggesusers\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 counting 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 \code{k} or at most \code{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 dramatically, # 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 <- critFunC(M = net, clu = clu, approaches = "val", blocks = c("nul", "com"), preSpecM = 4) plot(res) # We get the original partition } \keyword{cluster}% at least one, from doc/KEYWORDS blockmodeling/man/gplot1.Rd0000644000176200001440000000516713370034046015344 0ustar liggesusers\name{gplot1} \alias{gplot1} \alias{gplot2} %- Also NEED an '\alias' for EACH other topic documented here. \title{A wrapper for function gplot - Two-Dimensional Visualization of Graphs} \description{ The function calls function \code{gplot} from the library \code{sna} with different defaults. Use fun for plotting image graphs. } \usage{ gplot1(M, diag = TRUE, displaylabels = TRUE, boxed.labels = FALSE, loop.cex = 4, 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 matrix (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 \code{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{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/reorderImage.Rd0000644000176200001440000000306213370034046016533 0ustar liggesusers\name{reorderImage} \alias{reorderImage} %- Also NEED an '\alias' for EACH other topic documented here. \title{Reordering 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 order 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, A.}{Ziberna, A.} (2007). Generalized Blockmodeling of Valued Networks. Social Networks, 29(1), 105-126. doi: 10.1016/j.socnet.2006.04.002 \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 } \author{Ales Ziberna} \seealso{\code{\link{critFunC}}, \code{\link{plot.mat}}, \code{\link{clu}}, \code{\link{IM}}, \code{\link{err}}} %\examples{ %} \keyword{manip}% at least one, from doc/KEYWORDS blockmodeling/man/rand.Rd0000644000176200001440000000170713370034046015056 0ustar liggesusers\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 & 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 form of vectors, where for each unit a cluster membership is given.} \item{tab}{A contingency table obtained as a table(clu1, clu2).} } \value{ The value of Rand Index (corrected/adjusted for chance). } \references{Hubert, L., & Arabie, P. (1985). Comparing Partitions. Journal of Classification, 2(1), 193-218.} \author{\enc{Aleš Žiberna}{Ales Ziberna}} \keyword{cluster}% at least one, from doc/KEYWORDS blockmodeling/man/find.m.Rd0000644000176200001440000000760313370034046015306 0ustar liggesusers\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 maximum value of \code{m/cut} where a certain 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 optimization 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, especially if \code{cormet} 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 (different kinds of units with no ties among themselves. If the network is not two-mode, the matrix must be square.} \item{clu}{A partition. Each unique value represents one cluster. If the network is one-mode, then 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 status of diagonal be acknowledged.} \item{cormet}{Which method should be used to correct for different maximum error contributions\cr "none" - no correction\cr "censor" - censor values larger than \code{M}\cr "correct" - so that the maximum possible error contribution of the cell is the same regardless of a condition (either that something must be 0 or at least \code{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 evaluated. If \code{cuts="all"} (default), all unique values are evaluated.} \item{neval}{A 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 inconsistencies are the same.} \item{ms}{The values of m where the function should be evaluated.} \item{\dots}{Other parameters to \code{crit.fun}.} } \value{ A matrix of maximal \code{m/cut} values. } \references{ Doreian, P., Batagelj, V. & Ferligoj, A. \enc{Anuška}{Anuska} (2005). Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press. \enc{Žiberna, A.}{Ziberna, A.} (2007). Generalized Blockmodeling of Valued Networks. Social Networks, 29(1), 105-126. doi: 10.1016/j.socnet.2006.04.002 \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 \enc{Žiberna, A.}{Ziberna, A.} (2014). Blockmodeling of multilevel networks. Social Networks, 39(1), 46-61. doi: 10.1016/j.socnet.2014.04.002 } \author{\enc{Aleš Žiberna}{Ales Ziberna}} \seealso{\code{\link{critFunC}} and maybe also \code{\link{optParC}}, \code{\link{plotMat}}} \keyword{cluster}% at least one, from doc/KEYWORDS blockmodeling/man/sedist.Rd0000644000176200001440000000774213370034046015432 0ustar liggesusers\name{sedist} \alias{sedist} %- Also NEED an '\alias' for EACH other topic documented here. \title{Computes distances in terms of Structural equivalence (Lorrain & White, 1971)} \description{ The functions compute 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 allowed by functions dist, \code{"cor"} or \code{"cov"} (all \code{package::stats}) or just \code{"cor"} or \code{"cov"} (given as a character).} \item{fun}{Which function should be used to compute distances (given as a 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 \code{"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]. These two comparisons are weighted by 2. This should be used with Euclidean distance to get the corrected Euclidean distance with p = 2.\cr \code{"switch2"} - the same (alias)\cr \code{"switch1"} - the same as above, only that the two comparisons are weighted by 1. This should be used with Euclidean distance to get the corrected Wuclidean distance with p = 1.\cr \code{"ignore"} (diagonal) - Diagonal is ignored. This should be used with Euclidean distance to get the corrected Euclidean distance with p = 0.\cr \code{"none"} - the matrix is used "as is"} \item{use}{For use with methods \code{"cor"} and \code{"cov"}, for other methods (the default option should be used if \code{handle.interaction == "ignore"}), \code{"pairwise.complete.obs"} are always used, if \code{stats.dist.cor.cov = TRUE}.} \item{\dots}{Additional arguments to \code{fun}} } \details{ If both \code{method} and \code{fun} are \code{"default"}, the Euclidean distances are computed. The \code{"default"} method for \code{fun = "dist"} is "euclidean" 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(1-2), 63-90. doi: 10.1016/0378-8733(92)90014-X Lorrain, F., & White, H. C. (1971). Structural equivalence of individuals in social networks. Journal of Mathematical Sociology, 1(1), 49-80. doi: 10.1080/0022250X.1971.9989788 } \author{\enc{Aleš Žiberna}{Ales Ziberna}} \seealso{\code{\link{dist}}, \code{\link{hclust}}, \code{\link{REGE}}, \code{\link{optParC}}, \code{\link{optParC}}, \code{\link{optRandomParC}}} \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/ss.Rd0000644000176200001440000000111213370034046014545 0ustar liggesusers\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/genRandomPar.Rd0000644000176200001440000000365413370034046016512 0ustar liggesusers\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 called by the function \code{\link{optRandomParC}.} } \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 allowed group size.} \item{maxgr}{Maximal allowed 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 & Mrvar, 2006). If \code{FALSE}, all partitions are selected completely at random while making sure that the partitions have the required number of clusters. \cr \code{probGenMech} - Here the probabilities for 4 different generating mechanisms 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 mechanisms are the same as implemented in Pajek (the second one has almost all units in only one cluster) and the fourth is completely random (from uniform distribution). } } \value{ A random partition in the format required by \code{\link{optRandomParC}}. If a network has several modes, then a list of partitions, one for each mode. } \references{ Batagelj, V., & Mrvar, A. (2006). Pajek 1.11. Retrieved from \url{http://vlado.fmf.uni-lj.si/pub/networks/pajek/} } \author{\enc{Aleš Žiberna}{Ales Ziberna}} \keyword{cluster} blockmodeling/man/two2one.Rd0000644000176200001440000000425113370034046015524 0ustar liggesusers\name{two2one} \alias{two2one} \alias{one2two} %- Also NEED an '\alias' for EACH other topic documented here. \title{Two-mode network conversions} \description{ Converting two mode networks from two to one mode matrix representation and vice versa. If a two-mode matrix is converted into 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{ Function returns list with the elements: a two mode matrix of a 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{optParC}}, \code{\link{optParC}}, \code{\link{optRandomParC}}, \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 # Converting one to two mode matrix and plotting plot.mat(one2two(M1, clu = clu)$M, clu = clu) } \keyword{cluster}% at least one, from doc/KEYWORDS \keyword{graphs}% at least one, from doc/KEYWORDS blockmodeling/man/blockmodeling-package.Rd0000644000176200001440000000620213621546554020342 0ustar liggesusers\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{ Doreian, P., Batagelj, V. & Ferligoj, A. (2005). Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press. \enc{Žiberna, A.}{Ziberna, A.} (2007). Generalized Blockmodeling of Valued Networks. Social Networks, 29(1), 105-126. doi: 10.1016/j.socnet.2006.04.002 \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 \enc{Žiberna, A.}{Ziberna, A.} (2014). Blockmodeling of multilevel networks. Social Networks, 39(1), 46-61. doi: 10.1016/j.socnet.2014.04.002 White, D. R., & Reitz, K. P. (1983). Graph and semigroup homomorphisms on networks of relations. Social Networks, 5(2), 193-234. White, D. R. (2005). REGGE. Retrieved from http://eclectic.ss.uci.edu/~drwhite/REGGE/. } \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{critFunC}}, \code{\link{optParC}}, \code{\link{optRandomParC}}, \code{\link{REGE}}, \code{\link{plot.mat}} } \examples{ n <- 8 # If larger, the number of partitions increases dramatically, # 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 partition and then optimize it all.par <- nkpartitions(n = n, k = length(tclu)) # Forming the partitions all.par <- lapply(apply(all.par, 1, list), function(x) x[[1]]) # Optimizing one partition res <- optParC(M = net, clu = all.par[[sample(1:length(all.par), size = 1)]], approaches = "hom", homFun = "ss" , blocks = "com") plot(res) # Hopefully we get the original partition # Optimizing 10 random partitions with optRandomParC res <- optRandomParC(M = net, k = 2, rep = 10, approaches = "hom", homFun = "ss", blocks = "com") plot(res) # Hopefully we get the original partition # Using indirect approach - structural equivalence D <- sedist(M = net) plot.mat(net, clu = cutree(hclust(d = D, method = "ward"), k = 2)) } blockmodeling/man/REGE.Rd0000644000176200001440000001351713621542243014660 0ustar liggesusers\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 & Reitz, 1983): \code{REGE, REGE.for} - Classical REGE or REGGE, as also implemented in Ucinet. Similarities in terms of regular equivalence are computed. The \code{REGE.for} is a wrapper for calling the FORTRAN subrutine written 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 whether they are implemented in R of FORTRAN. Needless to say, the functions implemented in FORTRAN are much faster. \code{REGE.ow, REGE.ow.for} - The above function, modified so that a best match is searched for each arc separately (and not for both arcs, if they exist, together). \code{REGE.nm.for} - REGE or REGGE, modified to use row and column normalized matrices instead of the original matrix. \code{REGE.ownm.for} - The above function, modified so that a best match for an outgoing ties is searched on row-normalized network and for incoming ties on column-normalized network. \code{REGD.for} - REGD or REGDI, a dissimilarity version of the classical REGE or REGGE. Dissimilarities in terms of regular equivalence are computed. The \code{REGD.for} is a wrapper for calling the FORTRAN subroutine written by White (1985b), modified to be called by R. \code{REGE.FC} - Actually an earlier version of REGE. The difference is in the denominator. See Žiberna (2007) for details. \code{REGE.FC.ow} - The above function, modified so that a best match is searched for each arc separately (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 iterations.} \item{until.change}{Should the iterations be stopped when no change occurs.} \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 equivalence, each third dimension 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 iterations.} \item{use.diag}{Should the diagonal be used - for functions implemented in R only.} ... } \references{ \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 White, D. R., & Reitz, K. P. (1983). Graph and semigroup homomorphisms on networks of relations. Social Networks, 5(2), 193-234. White, D. R.(1985a). DOUG WHITE'S REGULAR EQUIVALENCE PROGRAM. Retrieved from http://eclectic.ss.uci.edu/~drwhite/REGGE/REGGE.FOR. White, D. R. (1985b). DOUG WHITE'S REGULAR DISTANCES PROGRAM. Retrieved from http://eclectic.ss.uci.edu/~drwhite/REGGE/REGDI.FOR. White, D. R. (2005). REGGE. Retrieved from http://eclectic.ss.uci.edu/~drwhite/REGGE/. } \author{\enc{Aleš Žiberna}{Ales Ziberna} based on Douglas R. White's original REGE and REGD} \seealso{\code{\link{sedist}}, \code{\link{critFunC}}, \code{\link{optParC}}, \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.D"), k = 2)) # REGE returns similarities, which have to be converted to # disimilarities res <- optRandomParC(M = net, k = 2, rep = 10, approaches = "hom", homFun = "ss", blocks = "reg") 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/formatA.Rd0000644000176200001440000000162413370034046015521 0ustar liggesusers\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 matrix.} \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/recode.Rd0000644000176200001440000000117713370034046015374 0ustar liggesusers\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/man/critFunC.Rd0000644000176200001440000003450413446631542015660 0ustar liggesusers\name{critFunC} \alias{critFunC} \alias{optParC} %- Also NEED an '\alias' for EACH other topic documented here. \title{Functions for Generalized blockmodeling for valued networks} \description{ Functions for implementation of Generalized blockmodeling for valued networks where the values of the ties are assumed to be measured on at least interval scale. \code{critFunC} calculates the criterion function, based on the network, partition and blockmodel/equivalece. \code{optParC} optimizes a partition based on the criterion function based on a local search algorithm. } \usage{ critFunC(M, clu, approaches, blocks, isTwoMode = NULL, isSym = NULL, diag = 1, IM = NULL, EM = NULL, Earr = NULL, justChange = FALSE, rowCluChange = c(0, 0), colCluChange = c(0, 0), sameIM = FALSE, regFun = "max", homFun = "ss", usePreSpecM = NULL, preSpecM = NULL, save.initial.param = TRUE, relWeights = 1, posWeights = 1, blockTypeWeights = 1, combWeights = NULL, returnEnv = FALSE) optParC(M, clu, approaches, blocks, nMode = NULL, isSym = NULL, diag = 1, useMulti = FALSE, maxPar = 50, IM = NULL, EM = NULL, Earr = NULL, justChange = TRUE, sameIM = FALSE, regFun = "max", homFun = "ss", usePreSpecM = NULL, preSpecM = NULL, minUnitsRowCluster = 1, minUnitsColCluster = 1, maxUnitsRowCluster = 9999, maxUnitsColCluster = 9999, relWeights = 1, posWeights = 1, blockTypeWeights = 1, combWeights = NULL, exchageClusters = "all", save.initial.param = TRUE) } %- 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 themselves). 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. Similarly, if units are comprised of several sets, \code{clu} should be the list containing one vector for each set.} \item{approaches}{One of the approaches (for each relation in multi-relational netowrks in a vector) described in Žiberna (2007). Possible values are:\cr "bin" - binary blockmodeling,\cr "val" - valued blockmodeling,\cr "hom" - homogeneity blockmodeling,\cr "ss" - sum of squares homogeneity blockmodeling, and\cr "ad" - absolute deviations homogeneity blockmodeling.\cr \cr The last two options are "shorthand" for specifying \code{approaches="hom"} and \code{homFun} to either \code{"ss"} or \code{"ad"}.} \item{blocks}{A vector, a list of vectors or an array with names of allowed blocy types. \cr \cr Only listing of allowed block types (blockmodel is not pre-specified).\cr A vector with names of allowed blocktypes. For multi-relational networks, it can be a list of such vectors. For \code{approaches = "bin"} or \code{approaches = "val"}, at least two should be selected. Possible values are:\cr \code{"nul"} - null or empty block\cr \code{"com"} - complete block\cr \code{"rdo"}, \code{"cdo"} - row and column-dominant blocks (binary and valued approach only)\cr \code{"reg"} - (f-)regular block\cr \code{"rre"}, \code{"cre"} - row and column-(f-)regular blocks\cr \code{"rfn"}, \code{"cfn"} - row and column-dominant blocks (binary, valued only)\cr \code{"den"} - density block (binary approach only)\cr \code{"avg"} - average block (valued approach only)\cr \code{"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 A pre-specified blockmodel.\cr An array with dimensions four dimensions (see example below). The third and the fourth represent the clusters (for rows and columns). The first is as long as the maximum 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 second dimension is the number of relations (1 for single-relational networks). The values in the array should be the ones from above. The array can have only three dimensions in case of one-relational networks or if the same pre-specified blockmodel is assumed for all relations. Further, it can have only two dimensions, if in addition only one block type is allowed per block.} \item{isTwoMode}{\code{1} for one-mode networks and \code{2} for two-mode networks. The default value is set to \code{NULL}.} \item{isSym}{Specifying if the matrix (for each relation) is symetric.} \item{diag}{Should the special stauts of diagonal be acknowladged. The default value is set to \code{1}.} \item{IM}{The obtained image for objects. For debugging purposes only.} \item{EM}{Block errors by blocks. For debugging purposes only.} \item{Earr}{The array of errors for all allowed block types by next dimensions: allowed block types, relations, row clusters and column clusters. The dimensions should match the dimensions of the block argument if specified as an array. For debugging purposes only.} \item{justChange}{Value specifying if only the errors for changed clusters should be computed. Used only for debugging purposes by developers.} \item{rowCluChange}{An array holding the two row clusters where the change occured. Used only for debugging purposes by developers.} \item{colCluChange}{An array holding the col row clusters where the change occured. Used only for debugging purposes by developers.} \item{sameIM}{Should we damand the same blockmodel image for all relations. The default value is set to \code{FALSE}.} \item{regFun}{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 default value is set to \code{"max"}.} \item{homFun}{In case of homogenity blockmodeling two vairability criteria can be used: \code{"ss"} - sum of squares (set by default) and \code{"ad"} - absolute deviations.} \item{usePreSpecM}{Specifiying weather a pre-specified value should be used when computing inconsistency.} \item{preSpecM}{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. In case ob binary blockmodeling this argument is a threshold used for binerizing the network. Therefore all values with values lower than \code{preSpecM} are recoded into 0s, all other into 1s. For multi-relational networks, it can be a vector of such values. In case of pre-specified blockmodeling, it can have the same dimensions as \code{blocks}.} \item{save.initial.param}{Should the inital parameters (\code{approaches}, ...) be saved. The default value is \code{TRUE}.} \item{relWeights}{Weights for all type of relations in a blockmodel. The default value is set to \code{1}.} \item{posWeights}{Weigths for positions in the blockmodel (the dimensions must be the same as the error matrix (rows, columns)). For now this is a matix (two-dimensional) even for multi-relational networks.} \item{blockTypeWeights}{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, where the names are one or all allowed block types from \code{blocks}. If only some block types are specified, the other have a default weight of 1. The default value is set to \code{1}.} \item{combWeights}{Weights for all type of block used, The default value is set to \code{NULL}.The dimension must be the same as \code{blocks}, if \code{blocks} would be specified in array format (which is usual in pre-specified case).} \item{returnEnv}{Should the function also return the environment after its completion.} \item{useMulti}{Which version of local search should be used. The default value is set to \code{FALSE}. If \code{FALSE}, first possible all moves in random order and then all possible exchanges in random order are tired. When a move with lower value of criterion function is found, the algorithm moves to this new partition. If \code{TRUE} the version of local search where all possible moves and exchanges are tired first and then the one with the lowest error is selected and used. In this case, several optimal partitions are found. \code{maxPar} best partitions are returned.} \item{maxPar}{The number of partitions with optimal criterion fuction to be returned. Only used If \code{useMulti} is \code{TRUE}.} \item{nMode}{Number of nodes. If \code{NULL}, then determined from \code{clu}.} \item{minUnitsRowCluster}{Minimum number of units in row cluster.} \item{minUnitsColCluster}{Minimum number of units in col cluster.} \item{maxUnitsRowCluster}{Maximum number of units in row cluster.} \item{maxUnitsColCluster}{Maximum number of units in col cluster.} \item{exchageClusters}{A matrix of dimensions "number of clusters" x "number of clusters" indicating to which clusters can units from a specific cluster be moved. Useful for multilevel blockmodeling or/in some other cases where some units cannot mix.} } %\details{ %} \value{ \code{critFunC} returns a list containing: \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{EM}{Block errors by blocks.} \item{IM}{The obtained image for objects.} \item{BM}{Block means by block - only for Homogeneity blockmodeling.} \item{Earr}{The array of errors for all allowed block types by next dimensions: allowed block types, relations, row clusters and column clusters. The dimensions should match the dimensions of the block argument if specified as an array.}\cr \code{optParC} returns a list containing: \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{EM}{Block errors by blocks.} \item{IM}{The obtained image for objects.} \item{BM}{Block means by block - only for Homogeneity blockmodeling.} \item{Earr}{The array of errors for all allowed block types by next dimensions: allowed block types, relations, row clusters and column clusters. The dimensions should match the dimensions of the block argument if specified as an array.} \item{useMulti}{The value of the input paramter \code{useMulti}.} \item{bestRowParMatrix}{(If \code{useMulti = TRUE}) Matrix, where there are different solutions for columns, where rows represent units.} \item{sameErr}{The number of partitions with the minimum value of the criterion function.} } \references{ Doreian, P., Batagelj, V., & Ferligoj, A. (2005). Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press. \enc{Žiberna, A.}{Ziberna, A.} (2007). Generalized Blockmodeling of Valued Networks. Social Networks, 29(1), 105-126. doi: 10.1016/j.socnet.2006.04.002 \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 \enc{Žiberna, A.}{Ziberna, A.} (2014). Blockmodeling of multilevel networks. Social Networks, 39(1), 46-61. doi: 10.1016/j.socnet.2014.04.002 } \author{\enc{Aleš Žiberna}{Ales Ziberna}} \seealso{\code{\link{optRandomParC}}, \code{\link{IM}}, \code{\link{clu}}, \code{\link{err}}, \code{\link{plot.crit.fun}}} \examples{ # Generating a simple network corresponding to the simple Sum of squares # Structural equivalence with blockmodel: # nul com # nul nul 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 <- critFunC(M = net, clu = clu, approaches = "hom", homFun = "ss", blocks = "com") res$err # The error is relatively small res$BM # The block means are around 0 or 4 plot(res) # Computation of criterion function with the correct partition and correct pre-specified blockmodel # Prespecified blockmodel used # nul com # nul nul B <- array(NA, dim = c(1, 1, 2, 2)) B[1, 1, , ] <- "nul" B[1, 1, 1, 2] <- "com" B[1, 1, , ] res <- critFunC(M = net, clu = clu, approaches = "hom", homFun = "ss", blocks = B) res$err # The error is relatively small res$IM plot(res) # Computation of criterion function with the correct partition # and pre-specified blockmodel with some alternatives # Prespecified blockmodel used # nul nul|com # nul nul B <- array(NA, dim = c(2, 2, 2)) B[1, , ] <- "nul" B[2, 1, 2] <- "com" res <- critFunC(M = net, clu = clu, approaches = "hom", homFun = "ss", blocks = B) res$err # The error is relatively small res$IM plot(res) # Computation of criterion function with random partition clu.rnd <- sample(1:2, size = n, replace = TRUE) res.rnd <- critFunC(M = net, clu = clu.rnd, approaches = "hom", homFun = "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 <- critFunC(M = net, clu = clu, approaches = "val", blocks = c("nul", "com"), preSpecM = 4) res$err # The error is relatively 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 <- critFunC(M = net, clu = clu.rnd, approaches = "val", blocks = c("nul", "com"), preSpecM = 4) res.rnd$err # The error is larger res.rnd$IM # All blocks are probably nul plot(res.rnd) } \keyword{cluster}% at least one, from doc/KEYWORDS \keyword{graphs}% at least one, from doc/KEYWORDS blockmodeling/man/genMatrixMult.Rd0000644000176200001440000000246713370034046016736 0ustar liggesusers\name{genMatrixMult} \alias{genMatrixMult} %- Also NEED an '\alias' for EACH other topic documented here. \title{Generalized matrix multiplication} \description{ Computes a generalized matrix multiplication, where sum and product functions (elemet-wise and summary functions) can be replaced by arbitrary functions.} \usage{ genMatrixMult(A, B, FUNelement = "*", FUNsummary = sum) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{A}{The first matrix.} \item{B}{The second matrix.} % \item{digits}{The number of desired digits} % \item{FUN}{Function used for "shortening" the numbers.} \item{FUNelement}{Element-wise operator.} \item{FUNsummary}{Summary function.} } \value{ A character vector or matrix. } \author{\enc{Aleš Žiberna}{Ales Ziberna}} \seealso{\code{\link{matmult}}} \examples{ # Operations can be anything x <- matrix(letters[1:8], ncol = 2) y <- matrix(1:10, nrow = 2) genMatrixMult(x, y, FUNelement = paste, FUNsummary = function(x) paste(x, collapse = "|")) # Binary logic set.seed(1) x <- matrix(rbinom(8, size = 1, prob = 0.5) == 1, ncol = 2) y <- matrix(rbinom(10, size = 1, prob = 0.5) == 1, nrow = 2) genMatrixMult(x, y, FUNelement = "*", FUNsummary = any) } \keyword{array} % at least one, from doc/KEYWORDS \keyword{algebra} blockmodeling/man/clu.Rd0000644000176200001440000000575613375337171014737 0ustar liggesusers\name{clu} \alias{clu} \alias{partitions} \alias{IM} \alias{EM} \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, returned by functions \code{\link{critFunC}} or \code{\link{optRandomParC}}.} \usage{ clu(res, which = 1, ...) IM(res, which = 1, drop=TRUE, ...) EM(res, which = 1, drop=TRUE, ...) err(res, ...) partitions(res) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{res}{Result of function \code{\link{critFunC}} or \code{\link{optRandomParC}}.} \item{which}{From \code{which} (if there are more than one) "best" solution should the element be extracted. Warning! \code{which} grater than the number of "best" partitions produces an error.} \item{drop}{If \code{TRUE} (default), dimensions that have only one level are dropped (\code{drop} function is applied to the final result).} \item{\dots}{Not used.} } \value{ The desired element. } \references{ Doreian, P., Batagelj, V., & Ferligoj, A. (2005). Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press. \enc{Žiberna, A.}{Ziberna, A.} (2007). Generalized Blockmodeling of Valued Networks. Social Networks, 29(1), 105-126. doi: 10.1016/j.socnet.2006.04.002 \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 } \author{\enc{Aleš Žiberna}{Ales Ziberna}} \seealso{\code{\link{critFunC}}, \code{\link{plot.mat}}, \code{\link{optRandomParC}}} \examples{ n <- 8 # If larger, the number of partitions increases dramatically, # 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 partition and then optimize 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 <- optParC(M = net, clu = all.par[[sample(1:length(all.par), size = 1)]], approaches = "hom", homFun = "ss", blocks = "com") plot(res) # Hopefully we get the original partition clu(res) # Hopefully we get the original partition err(res) # Error IM(res) # Image matrix/array. EM(res) # Error matrix/array. } \keyword{manip}% at least one, from doc/KEYWORDS blockmodeling/man/Pajek.Rd0000644000176200001440000000750513370034046015166 0ustar liggesusers\name{Pajek} \alias{Pajek} \alias{loadnetwork} \alias{loadnetwork2} \alias{loadnetwork3} \alias{loadnetwork4} \alias{savevector} \alias{savenetwork} \alias{savematrix} \alias{loadmatrix} \alias{loadvector} \alias{loadvector2} \alias{loadpajek} \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 adapted to be called within \code{loadpajek}. \code{loadnetwork3} - Another version for reading networks. \code{loadnetwork4} - Another version for reading networks. \code{savenetwork} - Saves a matrix into a Pajek ".net" filename. \code{loadmatrix} - Loads a Pajek ".mat" filename as a matrix. \code{savematrix} - Saves a matrix into a Pajek ".mat" filename. \code{loadvector} - Loads a Pajek ".clu" filename as a vector. \code{loadvector2} - The same as above, but adapted to be called within \code{loadpajek} - as a consequence not suited for reading clusters. \code{savevector} - Saves a vector into a Pajek ".clu" filename. \code{loadpajek} - Loads a Pajek project file name (".paj") as a list with the following components: Networks, Partitions, Vectors and Clusters. Clusters and hierarchies are dismissed. } \usage{ loadnetwork(filename, useSparseMatrix = NULL, minN = 50) loadnetwork2(filename, useSparseMatrix = NULL, minN = 50, safe = TRUE, closeFile = TRUE) loadnetwork3(filename, useSparseMatrix = NULL, minN = 50) loadnetwork4(filename, useSparseMatrix = NULL, minN = 50, fill = FALSE) savenetwork(n, filename, twomode = "default", symetric = NULL) loadmatrix(filename) savematrix(n, filename, twomode = 1) loadvector(filename) loadvector2(filename) savevector(v, filename) loadpajek(filename) } %- 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 matrices can only be used if package Matrix is installed. The default \code{NULL} uses sparse matrices 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 \code{TRUE}, only the lower part of the matrix is used and the values are interpreted as "Edges", not "Arcs".} \item{v}{A vector.} \item{fill}{If \code{TRUE}, then in case the rows have unequal length, blank fields are added.} \item{safe}{If \code{FALSE} error will occur if not all vertices have labels. If \code{TRUE} reading works faster.} \item{closeFile}{Should the connection be closed at the end. Should be always \code{TRUE} if function is used directly.}} \value{ NULL, a matrix or a vector (see Description). } \references{ Batagelj, V., & Mrvar. A. (1999). Pajek - Program for Large Network Analysis. Retrieved from \url{http://vlado.fmf.uni-lj.si/pub/networks/pajek/}. de Nooy, W., Mrvar, A., & Batagelj. V. (2005). Exploratory Social Network Analysis with Pajek. London: SAGE Publications. } \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{critFunC}}, \code{\link{optRandomParC}}} \keyword{graphs}% at least one, from doc/KEYWORDS \keyword{file}% at least one, from doc/KEYWORDS blockmodeling/man/optRandomParC.Rd0000644000176200001440000002630713440452304016645 0ustar liggesusers \name{optRandomParC} \alias{optRandomParC} %- Also NEED an '\alias' for EACH other topic documented here. \title{Optimizing a set of partitions based on the value of a criterion function} \description{ The function optimizes a set of partitions based on the value of a criterion function (see \code{\link{critFunC}} for details on the criterion function) for a given network and blockmodel for Generalized blockmodeling (Žiberna, 2007) 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 or the number of clusters and a number of partitions to generate can be specified (\code{optParC}). } \usage{ optRandomParC(M, k, approaches, blocks, rep, save.initial.param = TRUE, save.initial.param.opt = FALSE, deleteMs = TRUE, max.iden = 10, switch.names = NULL, return.all = FALSE, return.err = TRUE, seed = NULL, RandomSeed = NULL, parGenFun = genRandomPar, mingr = NULL, maxgr = NULL, addParam = list(genPajekPar = TRUE, probGenMech = NULL), maxTriesToFindNewPar = rep * 10, skip.par = NULL, useOptParMultiC = FALSE, useMulti = useOptParMultiC, printRep = ifelse(rep <= 10, 1, round(rep/10)), n = NULL, nCores = 1, ...) } %- 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 themselves). If the network is not two-mode, the matrix must be square.} \item{k}{The number of clusters used in the generation of partitions.} \item{approaches}{One of the approaches (for each relation in multi-relational netowrks in a vector) described in Žiberna (2007). Possible values are:\cr "bin" - binary blockmodeling,\cr "val" - valued blockmodeling,\cr "hom" - homogeneity blockmodeling,\cr "ss" - sum of squares homogeneity blockmodeling, and\cr "ad" - absolute deviations homogeneity blockmodeling.\cr \cr The last two options are "shorthand" for specifying \code{approaches="hom"} and \code{homFun} to either \code{"ss"} or \code{"ad"}.} \item{blocks}{A vector, a list of vectors or an array with names of allowed blocy types. \cr \cr Only listing of allowed block types (blockmodel is not pre-specified).\cr A vector with names of allowed blocktypes. For multi-relational networks, it can be a list of such vectors. For \code{approaches = "bin"} or \code{approaches = "val"}, at least two should be selected. Possible values are:\cr \code{"nul"} - null or empty block\cr \code{"com"} - complete block\cr \code{"rdo"}, \code{"cdo"} - row and column-dominant blocks (binary and valued approach only)\cr \code{"reg"} - (f-)regular block\cr \code{"rre"}, \code{"cre"} - row and column-(f-)regular blocks\cr \code{"rfn"}, \code{"cfn"} - row and column-dominant blocks (binary, valued only)\cr \code{"den"} - density block (binary approach only)\cr \code{"avg"} - average block (valued approach only)\cr \code{"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 A pre-specified blockmodel.\cr An array with dimensions four dimensions (see example below). The third and the fourth represent the clusters (for rows and columns). The first is as long as the maximum 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 second dimension is the number of relations (1 for single-relational networks). The values in the array should be the ones from above. The array can have only three dimensions in case of one-relational networks or if the same pre-specified blockmodel is assumed for all relations. Further, it can have only two dimensions, if in addition only one block type is allowed per block.} \item{rep}{The number of repetitions/different starting partitions to check.} \item{save.initial.param}{Should the initial parameters (\code{approaches}, ...) be saved. The default value is \code{TRUE}.} \item{save.initial.param.opt}{Should the inital parameters(\code{approaches}, ...) of using \code{optParC} be saved. The default value is \code{FALSE}.} \item{deleteMs}{Delete networks/matrices from the results of to save space.} \item{max.iden}{Maximum number of results that should be saved (in case there are more than \code{max.iden} results with minimal error, only the first \code{max.iden} will be saved).} \item{switch.names}{Should partitions that only differ in group names be considered equal.} \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{seed}{Optional. The seed for random generation of partitions.} \item{RandomSeed}{Optional. Integer vector, containing the random number generator. It is only looked for in the user's workspace.} \item{parGenFun}{The function (object) that will generate random partitions. The default function is \code{\link{genRandomPar}}. The function has to accept the following parameters: \code{k} (number o of partitions by modes, \code{n} (number of units by modes), \code{seed} (seed value for random generation of partition), \code{addParam} (a list of additional parameters).} \item{mingr}{Minimal allowed group size.} \item{maxgr}{Maximal allowed group size.} \item{addParam}{A list of additional parameters for function specified above. In the usage section they are specified for the default function \code{\link{genRandomPar}}.} \item{genPajekPar}{Should the partitions be generated as in Pajek.} \item{probGenMech}{Should the probabilities for different mechanisms for specifying the partitions be set. If \code{probGenMech} is not set, it is determined based on the parameter \code{genPajekPar}.} \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}.} \item{skip.par}{The partitions that are not allowed or were already checked and should therefore be skipped.} \item{useOptParMultiC}{For backward compatibility. May be removed soon. See next argument.} \item{useMulti}{Which version of local search should be used. Default is currently \code{FALSE}. If \code{FALSE}, first possible all moves in random order and then all possible exchanges in random order are tried. When a move with lower value of criterion function is found, the algorithm moves to this new partition. If \code{TRUE} the version of local search where all possible moves and exchanges are tried first and then the one with the lowest error is selected and used. In this case, several optimal partitions are found. \code{maxPar} best partitions are returned.} \item{printRep}{Should some information about each optimization be printed.} \item{n}{The number of units by "modes". It is used only for generating random partitions. It has to be set only if there are more than two modes or if there are two modes, but the matrix representing the network is one mode (both modes are in rows and columns).} \item{nCores}{Number of cores to be used. Value \code{0} means all available cores. It can also be a cluster object.} \item{\dots}{Arguments passed to other functions, see \code{\link{critFunC}}.} } \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 empirical network with the ideal network for a given blockmodel (model,approach,...) and parititions.} \item{nIter}{The vector of the number of iterations used - one value for each starting partition that was optimized. It can show that \code{maxiter} is too low if a lot of these values have the value of \code{maxiter}.} \item{checked.par}{If selected - A list of checked partitions. If \code{merge.save.skip.par} is \code{TRUE}, this list also includes the partitions in \code{skip.par}.} \item{call}{The call used to call the function.} \item{initial.param}{If selected - The initial parameters are used.} } \section{Warning}{ It should be noted that the time complexity of package blockmodeling is increasing with the number of units and the number of clusters (due to its algorithm). Therefore the analysis of network with more than 100 units can take a lot of time (from a few hours to a few days). } \references{ Batagelj, V., & Mrvar, A. (2006). Pajek 1.11. Retrieved from \url{http://vlado.fmf.uni-lj.si/pub/networks/pajek/} Doreian, P., Batagelj, V. & Ferligoj, A. (2005). Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press. \enc{Žiberna, A.}{Ziberna, A.} (2007). Generalized Blockmodeling of Valued Networks. Social Networks, 29(1), 105-126. doi: 10.1016/j.socnet.2006.04.002 \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 \enc{Žiberna, A.}{Ziberna, A.} (2014). Blockmodeling of multilevel networks. Social Networks, 39(1), 46-61. doi: 10.1016/j.socnet.2014.04.002 } \author{\enc{Aleš Žiberna}{Ales Ziberna}} \seealso{\code{\link{critFunC}}} \examples{ n <- 8 # If larger, the number of partitions increases dramatically # 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 partition and then optimize it all.par <- nkpartitions(n = n, k = length(tclu)) # Forming the partitions all.par <- lapply(apply(all.par, 1, list), function(x)x[[1]]) # Optimizing one partition res <- optParC(M = net, clu = all.par[[sample(1:length(all.par), size = 1)]], approaches = "hom", homFun = "ss", blocks = "com") plot(res) # Hopefully we get the original partition # Optimizing 10 random chosen partitions with optRandomParC res <- optRandomParC(M = net, k = 2, rep = 10, approaches = "hom", homFun = "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/fun.by.blocks.Rd0000644000176200001440000000631013370034046016602 0ustar liggesusers\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 function 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 = "default", sortNames = TRUE, FUN = "mean", ...) \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 (different kinds of units with no ties among themselves. 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 (different kinds of units with no ties among themselves. If the network is not two-mode, the matrix must be square.} \item{clu}{A partition. Each unique value represents one cluster. If the network is one-mode, then this should be a vector, else a list of vectors, one for each mode.} \item{ignore.diag}{Should the diagonal be ignored.} \item{sortNames}{Should the rows and columns of the matrix be sorted based on their names.} \item{FUN}{The 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, A.}{Ziberna, A.} (2007). Generalized Blockmodeling of Valued Networks. Social Networks, 29(1), 105-126. doi: 10.1016/j.socnet.2006.04.002 \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 } \author{\enc{Aleš Žiberna}{Ales Ziberna}} \seealso{\code{\link{optRandomParC}}, \code{\link{optParC}}} \examples{ n <- 8 # If larger, the number of partitions increases dramatically, # 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) # Optimizing 10 random partitions with optRandomParC res <- optRandomParC(M = net, k = 2, rep = 10, approaches = "hom", homFun = "ss", blocks = "com") plot(res) # Hopefully we get the original partition fun.by.blocks(res) # Computing mean by blocks, ignoring the diagonal (default) } \keyword{cluster}% at least one, from doc/KEYWORDS \keyword{math}% at least one, from doc/KEYWORDS blockmodeling/man/plot.mat.Rd0000644000176200001440000003677713415061402015703 0ustar liggesusers \name{plot.mat} \alias{plot.mat} \alias{plotMat} %\alias{plot.mat.nm} \alias{plotMatNm} \alias{plot.array} \alias{plotArray} \alias{plot.crit.fun} \alias{plot.opt.par} \alias{plot.opt.par.mode} \alias{plot.opt.more.par} \alias{plot.opt.more.par.mode} %- Also NEED an '\alias' for EACH other topic documented here. \title{Functions for plotting a partitioned matrix (representing the network)} \description{ The main function \code{plot.mat} or \code{plotMat} 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} or \code{plotMat} for convenience when plotting the results of the corresponding functions. The \code{plotMatNm} plots two matrices based on M, normalized by rows and columns, next to each other. The \code{plot.array} or \code{plotArray} plots an array. \code{plot.mat.nm} has been replaced by \code{plotMatNm}. } \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 = FALSE, 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.01, % y.axis.val.pos = -0.01, 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 = NULL, wIM = NULL, use.IM = % length(dim(IM)) == length(dim(M)) | !is.null(wIM), % dens.leg = c(null = 100, nul = 100), blackdens = 70, % plotLines = FALSE, frameMatrix = TRUE, x0ParLine = % -0.1, x1ParLine = 1, y0ParLine = 0, y1ParLine = 1.1, % colByUnits = NULL, colByRow = NULL, colByCol = NULL, % mulCol = 2, joinColOperator = "+", colTies = FALSE, % maxValPlot = NULL, printMultipliedMessage = TRUE, % replaceNAdiagWith0 = TRUE, ...) plotMat(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 = FALSE, 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.01, y.axis.val.pos = -0.01, 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 = NULL, wIM = NULL, use.IM = length(dim(IM)) == length(dim(M)) | !is.null(wIM), dens.leg = c(null = 100, nul = 100), blackdens = 70, plotLines = FALSE, frameMatrix = TRUE, x0ParLine = -0.1, x1ParLine = 1, y0ParLine = 0, y1ParLine = 1.1, colByUnits = NULL, colByRow = NULL, colByCol = NULL, mulCol = 2, joinColOperator = "+", colTies = FALSE, maxValPlot = NULL, printMultipliedMessage = TRUE, replaceNAdiagWith0 = TRUE, colLabels = FALSE, ...) % 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))) plotMatNm(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))) %plot.array(x = M, M = x, ..., main.title = NULL, main.title.line % = -2, mfrow = NULL) plotArray(x = M, M = x, IM = NULL, ..., main.title = NULL, main.title.line = -2, mfrow = NULL) \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 = FALSE, 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.01, y.axis.val.pos = -0.01, 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 = NULL, wIM = NULL, use.IM = length(dim(IM)) == length(dim(M)) | !is.null(wIM), dens.leg = c(null = 100, nul = 100), blackdens = 70, plotLines = FALSE, frameMatrix = TRUE, x0ParLine = -0.1, x1ParLine = 1, y0ParLine = 0, y1ParLine = 1.1, colByUnits = NULL, colByRow = NULL, colByCol = NULL, mulCol = 2, joinColOperator = "+", colTies = FALSE, maxValPlot = NULL, printMultipliedMessage = TRUE, replaceNAdiagWith0 = TRUE, colLabels = FALSE, ...) \method{plot}{crit.fun}(x, main = NULL, ...) \method{plot}{array}(x = M, M = x, IM = NULL, ..., main.title = NULL, main.title.line = -2, mfrow = 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, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{A result from a corresponding function or a matrix or similar object representing a network.} \item{M}{A matrix or similar object representing a network - either \code{x} or \code{M} must be supplied - both are here to make the code compatible with generic and with older functions.} \item{clu}{A partition. Each unique value represents one cluster. If the network is one-mode, then this should be a vector, else a list of vectors, one for each mode.} \item{ylab}{Label for y axis.} \item{xlab}{Label for x axis.} \item{main}{Main title.} \item{main.title}{Main title in \code{plot.array} version.} \item{main.title.line}{The line in which main title is printed in \code{plot.array} version.} \item{mfrow}{\code{mfrow} Argument to \code{par} - number of row and column plots to be plotted on one figure.} \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 plotted.} \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 ignored, 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' margin of the plot, default is 'inner' margin.} \item{title.line}{The line (from the top) where the title should be printed. The suitable values depend heavily on the displayed type.} \item{mar}{A numerical vector of the form \code{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 ordinary plots is \code{c(5, 4, 4, 2) + 0.1}, while this function default is \code{c(0.5, 7, 8.5, 0) + 0.1}.} \item{cex.val}{The size of the values printed. The default is \code{10 / 'number of units'}.} \item{val.y.coor.cor}{Correction for centering the values in the squares in y direction.} \item{val.x.coor.cor}{Correction for centering the values in the squares 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 \code{rownames} or \code{colnames} is not \code{NULL}.} \item{print.x.axis.val}{Should the x axis values be printed. Default prints each axis if \code{rownames} or \code{colnames} is not \code{NULL}.} \item{print.y.axis.val}{Should the y axis values be printed. Default prints each axis if \code{rownames} or \code{colnames} is not \code{NULL}.} \item{x.axis.val.pos}{The x coordinate of the y axis values.} \item{y.axis.val.pos}{The y coordinate 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 separates the partitions.} \item{par.line.col}{The color of the line that separates the partitions.} \item{IM.dens}{The density of shading lines in each block.} \item{IM}{The image (as obtained with \code{critFunC}) of the blockmodel. \code{dens.leg} is used to translate this image into \code{IM.dens}.} \item{wnet}{Specifies which matrix (if more) should be plotted - used if \code{M} is an array.} \item{wIM}{Specifies which \code{IM} (if more) should be used for plotting. The default value is set to \code{wnet}) - used if \code{IM} is an array.} \item{use.IM}{Specifies if \code{IM} should be used for plotting.} \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 colors of lines be printed in white.} \item{plotLines}{Should the lines in the matrix be printed. The default value is set to \code{FALSE}, best set to \code{TRUE} for very small networks.} \item{frameMatrix}{Should the matrix be framed (if \code{plotLines} is \code{FALSE}). The default value is set to \code{TRUE}.} \item{x0ParLine}{Coordinates for lines separating clusters.} \item{x1ParLine}{Coordinates for lines separating clusters.} \item{y0ParLine}{Coordinates for lines separating clusters.} \item{y1ParLine}{Coordinates for lines separating clusters.} \item{colByUnits}{Coloring units. It should be a vector of unit length.} \item{colByRow}{Coloring units by rows. It should be a vector of unit length.} \item{colByCol}{Coloring units by columns. It should be a vector of unit length.} \item{mulCol}{Multiply color when joining with row, column. Only used when when \code{colByUnits} is not \code{NULL}.} \item{joinColOperator}{Function to join \code{colByRow} and \code{colByCol}. The default value is set to \code{"+"}.} \item{colTies}{If \code{TRUE}, ties are colored, if \code{FALSE}, 0-ties are colored.} \item{maxValPlot}{The value to use as a maximum when computing colors (ties with maximal positive value are plotted as black).} \item{printMultipliedMessage}{Should the message '* all values in cells were multiplied by' be printed on the plot. The default value is set to \code{TRUE}.} \item{replaceNAdiagWith0}{If \code{replaceNAdiagWith0 = TRUE} Should the \code{NA} values on the diagonal of a matrix be replaced with 0s.} \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 plotting parameters (to \code{par}) to be used in nm version} \item{which}{Which (if there are more than one) of optimal solutions to plot.} \item{colLabels}{Should the labels of units be colored. If \code{FALSE}, these are not collored, if \code{TRUE}, they are colored with colors of clusters as defined by palette. This can be aslo a vector of colors (or integers) for one-mode networks or a list of two such vectors for two-mode networks.} \item{\dots}{Aditional arguments to \code{plot.default} for \code{plotMat} and also to \code{plotMat} for other functions.} } \value{ The functions are used for their side effect - plotting. } \references{ \enc{Žiberna, A.}{Ziberna, A.} (2007). Generalized Blockmodeling of Valued Networks. Social Networks, 29(1), 105-126. doi: 10.1016/j.socnet.2006.04.002 \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 } \author{\enc{Aleš Žiberna}{Ales Ziberna}} \seealso{\code{\link{critFunC}}, \code{\link{optRandomParC}}} \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 plotMat(M = net, clu = clu, print.digits.cells = 3) class(net) <- "mat" plot(net, clu = clu) # See corresponding functions for examples for other ploting # functions # presented, that are essentially only the wrappers for "plot.max" } \keyword{graphs}% at least one, from doc/KEYWORDS \keyword{hplot}% at least one, from doc/KEYWORDS blockmodeling/man/ircNorm.Rd0000644000176200001440000000243713370034046015544 0ustar liggesusers\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's maximum from 1 (if not exactly 0). Also, if the all deviations in two consequtive iterations are smaller, the process is terminated.} \item{maxiter}{Maximum number of iterations. If reached, the process is terminated 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 approximately 1. apply(A.norm, 1, sum) apply(A.norm, 2, sum) } \keyword{manip} blockmodeling/DESCRIPTION0000644000176200001440000000202713622060220014563 0ustar liggesusersPackage: blockmodeling Type: Package Title: Generalized and Classical Blockmodeling of Valued Networks Version: 0.3.6 Date: 2020-1-28 Imports: stats, methods, Matrix, parallel Suggests: sna, doRNG, doParallel, foreach Author: Aleš Žiberna [aut, cre] Authors@R: person("Aleš", "Žiberna", email = "ales.ziberna@gmail.com", role = c("aut", "cre")) Maintainer: Aleš Žiberna Description: This is primarily meant as an implementation of generalized blockmodeling for valued networks. In addition, measures of similarity or dissimilarity based on structural equivalence and regular equivalence (REGE algorithms) can be computed and partitioned matrices can be plotted: Žiberna (2007), Žiberna (2008), Žiberna (2014). License: GPL (>= 2) Encoding: UTF-8 RoxygenNote: 6.0.1 NeedsCompilation: yes Packaged: 2020-02-14 16:54:52 UTC; zibernaa Repository: CRAN Date/Publication: 2020-02-15 21:20:16 UTC blockmodeling/src/0000755000176200001440000000000013621550334013654 5ustar liggesusersblockmodeling/src/REGE_OWNM_R.f900000644000176200001440000000440113370034045016033 0ustar liggesusers! 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, CM, DM 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 99 J=1,N SUM(I,J)= R(I,J,1) + R(J,I,2) DEG(I)=DEG(I) + SUM(I,J) 99 END DO 100 END DO ! 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 599 J = 1, i-1 B(i,j) = B(j,i) 599 END DO 600 END DO 700 CONTINUE END blockmodeling/src/REGE_NM_R.f900000644000176200001440000000405513370034045015572 0ustar liggesusers! 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, CM, DM 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 99 J=1,N SUM(I,J)= R(I,J,1) + R(J,I,2) DEG(I)=DEG(I) + SUM(I,J) 99 END DO 100 END DO ! 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 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 599 J = 1, i-1 B(i,j) = B(j,i) 599 END DO 600 END DO 700 CONTINUE END blockmodeling/src/REGE_OWNM_DIAG_R.f900000644000176200001440000000462313370034045016625 0ustar liggesusers! 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, CM, DM 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 99 J=1,N SUM(I,J)= R(I,J,1) + R(J,I,2) DEG(I)=DEG(I) + SUM(I,J) 99 END DO 100 END DO ! 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 599 J = 1, i-1 B(i,j) = B(j,i) 599 END DO 600 END DO 700 CONTINUE END blockmodeling/src/REGE_NE_R.f900000644000176200001440000000564713370034045015572 0ustar liggesusers! 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, SUMM, CMIKJM, DM, XMAX, CM 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 99 J=1,N SUM(I,J)=0.0 DO 50 KR=1,NR SUM(I,J)=SUM(I,J)+R(I,J,KR)+R(J,I,KR) 50 END DO DEG(I)=DEG(I)+SUM(I,J) 99 END DO 100 END DO ! 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 SUMM = SUMM +min (R(I,K,KR),r(j,m,kr)) +min (R(K,I,KR),r(m,j,kr)) 300 CONTINUE 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 599 J = 1, i-1 B(i,j) = B(j,i) 599 END DO 600 END DO ! 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_NE_R.f900000644000176200001440000000577213370034045015570 0ustar liggesusers! 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, SUMM, SM, DM, CMIKJM, XMIN 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 99 J=1,N SUM(I,J)=0.0 DO 50 KR=1,NR SM = R(I,J,KR)**2 + R(J,I,KR)**2 SUM(I,J)=SUM(I,J) + sm 50 END DO DEG(I)=DEG(I)+SUM(I,J) 99 END DO 100 END DO 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 summ = summ + (R(I,K,KR) - R(J,M,KR)) **2 + (R(K,i,KR) - R(M,j,KR)) **2 300 CONTINUE 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 CONTINUE 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 B(i,j) = B(j,i) 600 CONTINUE 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/init.c0000644000176200001440000000706613375213165015000 0ustar liggesusers#include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void critFun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void optPar(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void optParMulti(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void parArr2Vec(void *, void *, void *, void *, void *); extern void parVec2Arr(void *, void *, void *, void *, void *); /* .Fortran calls */ extern void F77_NAME(regd)(void *, void *, void *, void *, void *); extern void F77_NAME(regdne)(void *, void *, void *, void *, void *); extern void F77_NAME(regdow)(void *, void *, void *, void *, void *); extern void F77_NAME(regdowne)(void *, void *, void *, void *, void *); extern void F77_NAME(rege)(void *, void *, void *, void *, void *); extern void F77_NAME(regene)(void *, void *, void *, void *, void *); extern void F77_NAME(regenm)(void *, void *, void *, void *, void *); extern void F77_NAME(regenmdiag)(void *, void *, void *, void *, void *); extern void F77_NAME(regenmne)(void *, void *, void *, void *, void *); extern void F77_NAME(regeow)(void *, void *, void *, void *, void *); extern void F77_NAME(regeowne)(void *, void *, void *, void *, void *); extern void F77_NAME(regeownm)(void *, void *, void *, void *, void *); extern void F77_NAME(regeownmdiag)(void *, void *, void *, void *, void *); extern void F77_NAME(regeownmne)(void *, void *, void *, void *, void *); static const R_CMethodDef CEntries[] = { {"critFun", (DL_FUNC) &critFun, 30}, {"optPar", (DL_FUNC) &optPar, 37}, {"optParMulti", (DL_FUNC) &optParMulti, 42}, {"parArr2Vec", (DL_FUNC) &parArr2Vec, 5}, {"parVec2Arr", (DL_FUNC) &parVec2Arr, 5}, {NULL, NULL, 0} }; static const R_FortranMethodDef FortranEntries[] = { {"regd", (DL_FUNC) &F77_NAME(regd), 5}, {"regdne", (DL_FUNC) &F77_NAME(regdne), 5}, {"regdow", (DL_FUNC) &F77_NAME(regdow), 5}, {"regdowne", (DL_FUNC) &F77_NAME(regdowne), 5}, {"rege", (DL_FUNC) &F77_NAME(rege), 5}, {"regene", (DL_FUNC) &F77_NAME(regene), 5}, {"regenm", (DL_FUNC) &F77_NAME(regenm), 5}, {"regenmdiag", (DL_FUNC) &F77_NAME(regenmdiag), 5}, {"regenmne", (DL_FUNC) &F77_NAME(regenmne), 5}, {"regeow", (DL_FUNC) &F77_NAME(regeow), 5}, {"regeowne", (DL_FUNC) &F77_NAME(regeowne), 5}, {"regeownm", (DL_FUNC) &F77_NAME(regeownm), 5}, {"regeownmdiag", (DL_FUNC) &F77_NAME(regeownmdiag), 5}, {"regeownmne", (DL_FUNC) &F77_NAME(regeownmne), 5}, {NULL, NULL, 0} }; void R_init_blockmodeling(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, FortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } blockmodeling/src/REGD_R.f900000644000176200001440000000467713370034045015211 0ustar liggesusers! 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, SUMM, SM, CMIKJM, DM, XMIN 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 99 J=1,N SUM(I,J)=0.0 DO 50 KR=1,NR SM = R(I,J,KR)**2 + R(J,I,KR)**2 SUM(I,J)=SUM(I,J) + sm 50 END DO DEG(I)=DEG(I)+SUM(I,J) 99 END DO 100 END DO 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 summ = summ + (R(I,K,KR) - R(J,M,KR)) **2 + (R(K,i,KR) - R(M,j,KR)) **2 300 CONTINUE 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 B(i,j) = B(j,i) 600 END DO 650 CONTINUE IF(IQUIT.EQ.1) GO TO 800 700 CONTINUE 800 CONTINUE END blockmodeling/src/REGD_OW_R.f900000644000176200001440000000573313370034045015610 0ustar liggesusers! 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, SM, DM 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 99 J=1,N SUM(I,J)=0.0 DO 50 KR=1,NR SM = R(I,J,KR)**2 SUM(I,J)=SUM(I,J) + SM 50 END DO 99 END DO 100 END DO DO 102 I=1,N DEG(I)=0.0 DO 101 J=1,N DEG(I)=DEG(I)+SUM(I,J)+SUM(J,I) 101 END DO 102 END DO ! 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 IF(R(K,I,KR).NE.0.0) summ2 = summ2 + (R(K,I,KR) - R(M,J,KR)) **2 300 END DO 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 B(i,j) = B(j,i) 600 END DO 650 CONTINUE 700 CONTINUE END blockmodeling/src/REGE_NM_NE_R.f900000644000176200001440000000553413370034045016157 0ustar liggesusers! 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, CM, DM 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 99 J=1,N SUM(I,J)= R(I,J,1) + R(J,I,2) DEG(I)=DEG(I) + SUM(I,J) 99 END DO 100 END DO ! 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 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 599 J = 1, i-1 B(i,j) = B(j,i) 599 END DO 600 END DO ! 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.f900000644000176200001440000000614113370034045016165 0ustar liggesusers! 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, CM, DM 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 99 J=1,N SUM(I,J)=0.0 DO 50 KR=1,NR SUM(I,J)=SUM(I,J)+R(I,J,KR)+R(J,I,KR) 50 END DO DEG(I)=DEG(I)+SUM(I,J) 99 END DO 100 END DO ! 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)) SUMM2 = SUMM2 +min (R(K,I,KR),r(m,j,kr)) 300 END DO 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 599 J = 1, i-1 B(i,j) = B(j,i) 599 END DO 600 END DO ! 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_R.f900000644000176200001440000000456713370034045015615 0ustar liggesusers! 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, CM, DM, D 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 99 J=1,N SUM(I,J)=0.0 DO 50 KR=1,NR SUM(I,J)=SUM(I,J)+R(I,J,KR)+R(J,I,KR) 50 END DO DEG(I)=DEG(I)+SUM(I,J) 99 END DO 100 END DO 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)) SUMM2 = SUMM2 +min (R(K,I,KR),r(m,j,kr)) 300 END DO 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 599 J = 1, i-1 D = D + (B(i,j) - B(j,i) )**2 B(i,j) = B(j,i) 599 END DO 600 END DO 700 CONTINUE 1000 END blockmodeling/src/REGD_OW_NE_R.f900000644000176200001440000000705213370034045016166 0ustar liggesusers! 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, SM, DM 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 99 J=1,N SUM(I,J)=0.0 DO 50 KR=1,NR SM = R(I,J,KR)**2 SUM(I,J)=SUM(I,J) + SM 50 END DO 99 END DO 100 END DO DO 102 I=1,N DEG(I)=0.0 DO 101 J=1,N DEG(I)=DEG(I)+SUM(I,J)+SUM(J,I) 101 END DO 102 END DO ! 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 IF(R(K,I,KR).NE.0.0) summ2 = summ2 + (R(K,I,KR) - R(M,J,KR)) **2 300 END DO 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 B(i,j) = B(j,i) 600 END DO 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 END blockmodeling/src/REGE_NM_DIAG_R.f900000644000176200001440000000427713370034045016364 0ustar liggesusers! 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, CM, DM 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 99 J=1,N SUM(I,J)= R(I,J,1) + R(J,I,2) DEG(I)=DEG(I) + SUM(I,J) 99 END DO 100 END DO ! 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 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 599 J = 1, i-1 B(i,j) = B(j,i) 599 END DO 600 END DO 700 CONTINUE END blockmodeling/src/REGE_R.f900000644000176200001440000000411713370034045015177 0ustar liggesusers! 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, SUMM, CMIKJM, CM, DM, XMAX 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 99 J=1,N SUM(I,J)=0.0 DO 50 KR=1,NR SUM(I,J)=SUM(I,J)+R(I,J,KR)+R(J,I,KR) 50 END DO DEG(I)=DEG(I)+SUM(I,J) 99 END DO 100 END DO ! 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 SUMM = SUMM +min (R(I,K,KR),r(j,m,kr)) +min (R(K,I,KR),r(m,j,kr)) 300 END DO 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 599 J = 1, i-1 B(i,j) = B(j,i) 599 END DO 600 END DO 700 CONTINUE END blockmodeling/src/blockmodelingC.c0000644000176200001440000027721013370034045016742 0ustar liggesusers/* WARNINGS: rfn and cfn blocks added only to binary and valued blockmodeling - no safety measures are in effect! This is an implementation of Generalized blockmodeling of valued (and binary) networks in C to be called from R. The structure is as follows: - main functions that are linked to R. These must include all functions for optimizing partitions - a function that computes (or updates) the criterion function of a partition and a blockmodel - functions for computing errors/inconsistencies for individual block types for all types of blockmodeling (hom,val,bin) - functions for computing row/column summaries for regular-like blocks - functions for computing measure of variation for homogeneity blockmodeling The implementation must support (when final): - several types of generalized blockmodeling, with the possibility to extend it (easily) with new types of blockmodeling or/and types of blocks - multirelational networks (with the possibility to have different or same images for all networks - at least one and two mode networks (preferably efficiently) and also 3-mode networks - efficient computations for symmetric networks - symmetrical block type (not yet implemented) - pre-specified blockmodeling - for valued blockmodeling this also means possibility to pre-specify the value from the which the deviations are computed (hom) or the value of parameter m by blocks (val) If possible, also: - possibility of different methods for "searching" for the partition - ways of optimising - eg. not only local search, but aslo gentic algorithm, tabu search, etc. - possibility to specify what kind of partitions are allowed (minimal/maximal group size, etc.) TODO: - allow penalties by relations (already implemented), by block types and by "positions". This could be implemented in C by just one 4d weighting array that could be in R computed (if desired) from those separate weighting schemes. */ #include #include #include #include #include /* Change these when you add new functions */ #define nRegFun 3 #define nHomFun 2 #define nBlockTypes 9 #define nApproaches 3 /* #define MaxNumOfDiffBlockTypes 10 */ #define min(a,b) ((a) < (b) ? (a) : (b)) #define max(a,b) ((a) > (b) ? (a) : (b)) double ss(double *px, int n, double preSpecVal); double ssP(double *px, int n, double preSpecVal); double ss0(double *px, int n, double preSpecVal); double ssPmin(double *px, int n, double preSpecVal); double ad(double *px, int n, double preSpecVal); double adP(double *px, int n, double preSpecVal); double ad0(double *px, int n, double preSpecVal); int randomInt(int n); /* A function with returns a random number on the interval [0, n-1]*/ int randomInt(int n) { int r; r = (int) (unif_rand()*n); return(r); } void randomCall(int *n, int *r); void randomCall(int *n, int *r){ GetRNGstate(); /* Get .Random.seed from R */ *r = randomInt(*n); PutRNGstate(); /* Write .Random.seed in R */ } /* Definition of an array of pointers to a function for computing some measure of variance*/ double (*phom[nHomFun][4])(double *px, int n, double preSpecVal); /* A function for computing sum of squares deviations from the mean*/ double ss(double *px, int n, double preSpecVal) { double ssx=0; double sumx=0; int i; for(i=0;i m){ m=preSpecVal; } for(i=0;i *db) - (*da < *db); } /* A function for computing sum of absolute deviations from the median*/ double ad(double *px, int n, double preSpecVal){ /*int cmp(double *x, double *y){ if(*x>*y) return(1); if(*y>*x) return((-1)); return(0); }*/ double med, sad = 0; int i; qsort(px,n,sizeof(double), cmp); if((n%2)==0){ med = ( px[n/2-1] + px[n/2])/2.0; }else{ med = px[(n)/2]; } for(i=0; i<(n/2) ;i++){ sad += med - px[i]; } for(i=n/2;i<(n);i++){ sad += px[i] - med; } return(sad); } /* A function for computing sum of absolute deviations from a given value*/ double adP(double *px, int n, double preSpecVal){ double sad = 0; int i; for(i=0; i<(n) ;i++){ sad += px[i]>preSpecVal ? (px[i]- preSpecVal): (preSpecVal - px[i]); } return(sad); } /* A function for computing sum of absolute deviations from a given value*/ double ad0(double *px, int n, double preSpecVal){ double sad = 0; int i; for(i=0; i<(n) ;i++){ sad += px[i]>0 ? (px[i]): ( - px[i]); } return(sad); } double adPmin(double *px, int n, double preSpecVal){ double med, sad = 0; int i; qsort(px,n,sizeof(double), cmp); if((n%2)==0){ med = ( px[n/2-1] + px[n/2])/2.0; }else{ med = px[(n)/2]; } if(preSpecVal > med){ med=preSpecVal; } for(i=0; i<(n/2) ;i++){ sad += med - px[i]; } for(i=n/2;i<(n);i++){ sad += px[i] - med; } return(sad); } /* Definition of an array of pointers to a function for computing some summary measure*/ double (*pregFuns[nRegFun])(double *px, int n); double maxv(double *px, int n){ double res=-INFINITY; for(int i = 0;i always returns 0*/ double doNotCare(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ return(0.0); } /* a function for computing error of the regular block - binary blockmodeling*/ double binReg(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of rows in the whole matrix/network nrb - number of rows in the block ncb - number of rows in the block */ int baseInd=relN*nr*nc; int ind2d; double *prs; double *pcs; prs = (double *) malloc(nrb*sizeof(double)); pcs = (double *) malloc(ncb*sizeof(double)); for(int i = 0; i0); } for(int i = 0; i0); } free(prs); free(pcs); return((nrb-nnr)*ncb + (ncb-nnc)*nnr); } /* a function for computing error of the column-regular block - binary blockmodeling*/ double binCre(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of columns in the whole matrix/network nrb - number of rows in the block ncb - number of columns in the block */ int baseInd=relN*nr*nc; int ind2d; double pcs=0; int nnc=0; for(int j = 0; j0); } return((ncb-nnc)*nrb); } /* a function for computing error of the row-regular block - binary blockmodeling*/ double binRre(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of columns in the whole matrix/network nrb - number of rows in the block ncb - number of columns in the block */ int baseInd=relN*nr*nc; double prs=0; int nnr=0; for(int i = 0; i0); } return((nrb-nnr)*ncb); } /* a function for computing error of the row-functional block - binary blockmodeling*/ double binRfn(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of columns in the whole matrix/network nrb - number of rows in the block ncb - number of columns in the block */ int baseInd=relN*nr*nc; double prs = 0; int nnr=0; double st=0; for(int i = 0; i0); st += prs; } return(st - nnr + (nrb-nnr)*ncb); } /* a function for computing error of the column-functional block - binary blockmodeling*/ double binCfn(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of columns in the whole matrix/network nrb - number of rows in the block ncb - number of columns in the block */ int baseInd=relN*nr*nc; int ind2d; double pcs = 0; double st = 0; int nnc=0; for(int j = 0; j0); st += pcs; } return(st - nnc + (ncb-nnc)*nrb); } /* a function for computing error of the complete block - binary blockmodeling*/ double binCom(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ double res=0; int baseInd=relN*nr*nc; int ind2d; for(int j = 0; j=nClus) nClus = pParVec[i]+1; } /* Rprintf("OK2"); */ *pnClus = nClus; /* Rprintf("OK3"); */ /*pnUnitsClu = (int *) malloc((*pnClus)*sizeof(int));*/ /*pParArr = (int *) malloc((*pnClus)*(*pn)*sizeof(int));*/ for(int i=0;i<*pn;i++){ pParArr[pParVec[i]*(*pn)+pnUnitsClu[pParVec[i]]]=i; pnUnitsClu[pParVec[i]]++; Rprintf("OK4.%i", i); } /* Rprintf("OK5"); */ } /* for now this function moves to improved partition as soon as it findes one */ /* however, the "move" is selected randomly, while it is true that "moves" are tried before "exchanges" */ void optPar(const double *pM, const int *pnr, const int *pnc, const int *pnRel, const int *pisTwoMode, const int *pisSym,const int *pdiag, const int *pnColClus, const int *pnRowClus, int *pnUnitsRowClu, int *pnUnitsColClu, int *prowParArr, int *pcolParArr,const int *papproaches, const int *pmaxBlockTypes,const int *pnBlockTypeByBlock, const int *pblocks, int *pIM, double *pEM, double *pEarr, double *perr, const int *pjustChange, int *prowCluChange, int *pcolCluChange, const int *psameIM, const int *pregFun, const int *phomFun, const int *pusePreSpec, const double *ppreSpecM, const int *pminUnitsRowCluster, const int *pminUnitsColCluster, const int *pmaxUnitsRowCluster, const int *pmaxUnitsColCluster, int *psameErr, int *pnIter, const double *pcombWeights, const int *pexchageClusters){ /* double *pM - pointer to array or matrix representiing the (multirelational) network int *pnr - pointer to the number of rows int *pnc - pointer to the number of columns int *pisTwoMode - pointer to 0 (false) or 1 (true) specifying it the network is two-mode int *pisSym - pointer to array of length (nRel - number of relation) specifying if the matrix (for each relation) is symetric) (0 - as any other value, 1 - seperately, 2 - ignore) int *pdiag - pointer to array of length (nRel - number of relation) 0 (false) or 1 (true) specifying how to treat the diagonal elments int *pnRel - pointer to the number of relations int *pnColClus - pointer to the number of column clusters int *pnRowClus - pointer to the number of column clusters int *pnUnitsRowClu - pointer to the array of the nummber of members of each row cluster int *pnUnitsColClu - pointer to the array of the nummber of members of each col cluster int *prowParArr - pointer to the array of arrays (one for each row cluster) of members of each row cluster int *pcolParArr - pointer to the array of arrays (one for each col cluster) of members of each col cluster int *papproaches - pointer to the array specifiying approach - one for each realation int *pmaxBlockTypes - pointer to maximum number of used block types int *pnBlockTypeByBlock - pointer to 3d array (Rel, row, col) specifiying the number of used allowed block types int *pblocks - pointer to the 4d array (nBlockTypesByBlock, Rel, row, col) specifiying allowed block types int *pIM - pointer to 3d array (Rel, row, col) specifiying the image matrix double *pEM - pointer to 3d array (Rel, row, col) specifiying the error for each block double *pEarr - pointer to the 4d array ((*pmaxBlockTypes), Rel, row, col) specifiying the errrors for each allowed block type - it is very important that the value is Infinitive for block types that are not allowed double *perr - pointer to the total error int *pjustChange - pointer to a value specifying if only the errors for changed clusters should be computed int *prowCluChange - pointer to an array holding the two row clusters where the change occured int *pcolCluChange - pointer to an array holding the col row clusters where the change occured int *psameIM - pointer to 0 (false) or 1 (true) specifiying if the image has to be the same for all relations int *pregFun - pointer to the 4d array ((*pmaxBlockTypes), Rel, row, col) specifiying the "summary" function used in f-regular line blocks int *phomFun - pointer to the array (one value for each rel) function used used for computing measure of variability in sum of squares blockmodeling int *pusePreSpec - pointer to 4d array ((*pmaxBlockTypes), Rel, row, col) specifiying weather a the pre-specified value should be used when computing inconsistency double *ppreSpecM - pointer to 4d array ((*pmaxBlockTypes), Rel, row, col) specifiying the pre-specified value to be used when computing inconsistency int *pminUnitsRowCluster - pointer to the minimum number of units in row cluster int *pminUnitsColCluster - pointer to the minimum number of units in col cluster int *pmaxUnitsRowCluster - pointer to the maximum number of units in row cluster int *pmaxUnitsColCluster - pointer to the maximum number of units in col cluster double *pcombWeights - pointer to a array of weights of the same dimmensions as blocks int *pexchageClusters - pointer to a matrix (nRowClust, nColClus) showing which clusters are exchangable */ /*Rprintf("OptParC\n");*/ /**/ /*Rprintf("pM: ");*/ /*for( int i=0;i<(*pnr)*(*pnc)*(*pnRel);i++){*/ /* Rprintf("%f ", pM[i]);*/ /*}*/ /*Rprintf("\n");*/ /* int *pzero; pzero = (int *) malloc(sizeof(int)); *pzero = 0; */ int zero = 0; /* Rprintf("test1");*/ GetRNGstate(); /* Get .Random.seed from R */ if(*pisTwoMode){ Rprintf("Optimization of two-mode networks is not yet supported\n"); } else { critFun(pM, pnr, pnc, pnRel, pisTwoMode, pisSym, pdiag, pnColClus, pnRowClus, pnUnitsRowClu, pnUnitsColClu, prowParArr, pcolParArr, papproaches, pmaxBlockTypes, pnBlockTypeByBlock, pblocks, pIM, pEM, pEarr, perr, &zero, prowCluChange, pcolCluChange, psameIM, pregFun, phomFun, pusePreSpec, ppreSpecM, pcombWeights); /*Rprintf("Initial error = %.2f\n", *perr);*/ /* prepare temoprary objects - start*/ /* best result - start*/ /* partition*/ int *pbestrowParArr; int *pbestnUnitsRowClu; pbestnUnitsRowClu = (int *) malloc((*pnRowClus)*sizeof(int)); pbestrowParArr = (int *) malloc((*pnRowClus)*(*pnc)*sizeof(int)); for(int i=0;i<*pnRowClus;i++){ pbestnUnitsRowClu[i] = pnUnitsRowClu[i]; } for(int i=0;i<((*pnRowClus)*(*pnc));i++){ pbestrowParArr[i] = prowParArr[i]; } /* image matrix */ int *pbestIM; pbestIM = (int *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(int)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pbestIM[i] = pIM[i]; } /* number of block types by block - not needed int *pbestnBlockTypeByBlock; pbestnBlockTypeByBlock = (int *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(int)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pbestnBlockTypeByBlock[i] = pnBlockTypeByBlock[i]; } */ /* error matrix */ double *pbestEM; pbestEM = (double *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(double)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pbestEM[i] = pEM[i]; } /* error array by block types*/ double *pbestEarr; pbestEarr = (double *) malloc((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(double)); for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pbestEarr[i] = pEarr[i]; } double *pbesterr; pbesterr = (double *) malloc(sizeof(double)); *pbesterr = *perr; /* best result - end*/ /* temp result - start*/ /* partition*/ int *ptemprowParArr; int *ptempnUnitsRowClu; ptempnUnitsRowClu = (int *) malloc((*pnRowClus)*sizeof(int)); ptemprowParArr = (int *) malloc((*pnRowClus)*(*pnc)*sizeof(int)); for(int i=0;i<*pnRowClus;i++){ ptempnUnitsRowClu[i] = pnUnitsRowClu[i]; } for(int i=0;i<((*pnRowClus)*(*pnc));i++){ ptemprowParArr[i] = prowParArr[i]; } /* image matrix */ int *ptempIM; ptempIM = (int *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(int)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempIM[i] = pIM[i]; } /* number of block types by block - not needed int *ptempnBlockTypeByBlock; ptempnBlockTypeByBlock = (int *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(int)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempnBlockTypeByBlock[i] = pnBlockTypeByBlock[i]; } */ /* error matrix */ double *ptempEM; ptempEM = (double *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(double)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEM[i] = pEM[i]; } /* error array by block types*/ double *ptempEarr; ptempEarr = (double *) malloc((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(double)); for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEarr[i] = pEarr[i]; } double *ptemperr; ptemperr = (double *) malloc(sizeof(double)); *ptemperr = *perr; /* temp result - end*/ /* prepare temoprary objects - end*/ int improve=1; /*Rprintf("OK1\n");*/ /* loop until no impovement is found */ *pnIter=0; while(improve){ *pnIter = *pnIter + 1; /* copy temp results to permanent - start*/ /* partition*/ for(int i=0;i<*pnRowClus;i++){ pnUnitsRowClu[i] = ptempnUnitsRowClu[i]; } for(int i=0;i<((*pnRowClus)*(*pnc));i++){ prowParArr[i] = ptemprowParArr[i]; } /* image matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pIM[i] = ptempIM[i]; } /* error matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pEM[i] = ptempEM[i]; } /* error array by block types*/ for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pEarr[i] = ptempEarr[i]; } *perr = *ptemperr; /* copy temp results to permanent - end*/ improve=0; *psameErr = 1; /* to make the order of evaluation random - start */ /* randomize(); does not work */ int rnd; int rndClusters[*pnRowClus]; for(int i=0;i<*pnRowClus;i++){ rndClusters[i]=i; } /* to make the order of evaluation random - end */ int iClu, iClu2, iUnit, iUnit2; /* a loop over all clusters - random order */ for(int iRndClu=0;iRndClu<*pnRowClus;iRndClu++){ /* Rprintf("Start loop cluster 1\n"); */ /* to make the order of evaluation random - start*/ rnd=randomInt(*pnRowClus-iRndClu); iClu=rndClusters[rnd]; prowCluChange[0]=iClu; rndClusters[rnd]=rndClusters[*pnRowClus-iRndClu-1]; /* to make the order of evaluation random - end*/ /* a loop over all units inside clusters*/ /* to make the order of evaluation random - start*/ int rndUnitsInClu[pnUnitsRowClu[iClu]]; for(int i=0;iiClu){ rndClusters2[i-1]=i; } } /*Rprintf("OK 1.04\n");*/ /* to make the order of evaluation random - end*/ /* a loop over all other clusters - random order */ for(int iRndClu2=0;iRndClu2<(*pnRowClus-1);iRndClu2++){ /*Rprintf("Start loop cluster 2\n");*/ /* to make the order of evaluation random - start*/ rnd=randomInt(*pnRowClus - 1 - iRndClu2); /*Rprintf("rnd = %i, *pnRowClus - 1 - iRndClu2= %i\n", rnd, *pnRowClus - 1 - iRndClu2); */ iClu2=rndClusters2[rnd]; prowCluChange[1]=iClu2; rndClusters2[rnd]=rndClusters2[*pnRowClus - 2 - iRndClu2]; /*Rprintf("rndClusters2[rnd] = %i\n", rndClusters2[rnd]);*/ if (!pexchageClusters[iClu*(*pnRowClus)+iClu2]){ continue; } /* to make the order of evaluation random - end*/ if((pnUnitsRowClu[iClu]>(*pminUnitsRowCluster))&&(pnUnitsRowClu[iClu2]<(*pmaxUnitsRowCluster))){ /*Rprintf("OK1.1\n");*/ /* move unit to another cluster */ ptemprowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]]=ptemprowParArr[iClu*(*pnr)+iUnit]; /*Rprintf("OK1.2\n");*/ ptempnUnitsRowClu[iClu2]++; /* this line must be after the above line */ /*Rprintf("OK1.3\n");*/ ptempnUnitsRowClu[iClu]--; /* this line must be before the line below */ /*Rprintf("OK1.4\n");*/ ptemprowParArr[iClu*(*pnr)+iUnit]=ptemprowParArr[iClu*(*pnr)+ptempnUnitsRowClu[iClu]]; /*Rprintf("iClu = %i, iClu2= %i, iUnit=%i\n", iClu, iClu2, iUnit);*/ /*Rprintf("nClu = %i, nCluOld= %i, nClu2 = %i, nCluOld2= %i\n", ptempnUnitsRowClu[iClu], pnUnitsRowClu[iClu], ptempnUnitsRowClu[iClu2], pnUnitsRowClu[iClu2]); */ /*for(int i1=0;i1<(*pnRowClus);i1++){ Rprintf("cluster = %i, unitsCluster= %i: ", i1, ptempnUnitsRowClu[i1]); for(int i2=0;i2<(ptempnUnitsRowClu[i1]);i2++){ Rprintf("%i ", ptemprowParArr[i1*(*pnr)+i2]); } Rprintf("\n"); }*/ /*Rprintf("OK2\n");*/ /* here the new partition is evaluated*/ critFun(pM, pnr, pnc, pnRel, pisTwoMode, pisSym, pdiag, pnColClus, pnRowClus, ptempnUnitsRowClu, ptempnUnitsRowClu, ptemprowParArr, ptemprowParArr, papproaches, pmaxBlockTypes, pnBlockTypeByBlock, pblocks, ptempIM, ptempEM, ptempEarr, ptemperr, pjustChange, prowCluChange, prowCluChange, psameIM, pregFun, phomFun, pusePreSpec, ppreSpecM, pcombWeights); /*Rprintf("Error after move = %.2f\n", *ptemperr);*/ /*Rprintf("OK3\n");*/ if (*ptemperr< (*perr)) { /*Rprintf("OK4a\n");*/ /*Rprintf("################################################################\n"); */ improve=1; break; } else { if (*ptemperr == (*perr)) {*psameErr += 1;} /*Rprintf("OK4b\n");*/ /* undo if the improvement was not found */ ptempnUnitsRowClu[iClu2]--; /* this line must be before the line below */ ptemprowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]] = prowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]]; ptemprowParArr[iClu*(*pnr)+iUnit]=prowParArr[iClu*(*pnr)+iUnit]; ptempnUnitsRowClu[iClu]++; /* this line must be after the above line */ /* temp values must be set to equal permament to be updated as needed if justChange is used*/ if(*pjustChange){ /* temp result - copy "regular" to temp - start*/ /* image matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempIM[i] = pIM[i]; } /* error matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEM[i] = pEM[i]; } /* error array by block types*/ for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEarr[i] = pEarr[i]; } /* temp result - end*/ } } /*Rprintf("OK5\n");*/ } /*check the exchange of units only if iClu1 < iClu2 to avoid repeating the same move */ if(iClu < iClu2){ /* to make the order of evaluation random - start*/ int rndUnitsInClu2[pnUnitsRowClu[iClu2]]; for(int i=0;iiClu){ rndClusters2[i-1]=i; } } */ /*Rprintf("OK 1.04\n");*/ /* to make the order of evaluation random - end*/ /* a loop over all other clusters - random order */ /* for(int iRndClu2=0;iRndClu2<(*pnRowClus-1);iRndClu2++){ */ for(int iClu2=0;iClu2<(*pnRowClus);iClu2++){ if(iClu==iClu2) continue; /*Rprintf("Start loop cluster 2\n");*/ /* to make the order of evaluation random - start*/ /* rnd=randomInt(*pnRowClus - 1 - iRndClu2); */ /*Rprintf("rnd = %i, *pnRowClus - 1 - iRndClu2= %i\n", rnd, *pnRowClus - 1 - iRndClu2); */ /* iClu2=rndClusters2[rnd]; rndClusters2[rnd]=rndClusters2[*pnRowClus - 2 - iRndClu2]; */ /*Rprintf("rndClusters2[rnd] = %i\n", rndClusters2[rnd]);*/ prowCluChange[1]=iClu2; /*Rprintf("Test exchange - start\n");*/ if (!pexchageClusters[iClu*(*pnRowClus)+iClu2]){ continue; } /*Rprintf("Test exchange - end\n");*/ /* to make the order of evaluation random - end*/ if((pnUnitsRowClu[iClu]>(*pminUnitsRowCluster))&&(pnUnitsRowClu[iClu2]<(*pmaxUnitsRowCluster))){ /*Rprintf("OK1.1\n");*/ /* move unit to another cluster */ ptemprowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]]=ptemprowParArr[iClu*(*pnr)+iUnit]; /*Rprintf("OK1.2\n");*/ ptempnUnitsRowClu[iClu2]++; /* this line must be after the above line */ /*Rprintf("OK1.3\n");*/ ptempnUnitsRowClu[iClu]--; /* this line must be before the line below */ /*Rprintf("OK1.4\n");*/ ptemprowParArr[iClu*(*pnr)+iUnit]=ptemprowParArr[iClu*(*pnr)+ptempnUnitsRowClu[iClu]]; /*Rprintf("iClu = %i, iClu2= %i, iUnit=%i\n", iClu, iClu2, iUnit);*/ /*Rprintf("nClu = %i, nCluOld= %i, nClu2 = %i, nCluOld2= %i\n", ptempnUnitsRowClu[iClu], pnUnitsRowClu[iClu], ptempnUnitsRowClu[iClu2], pnUnitsRowClu[iClu2]);*/ /*Rprintf("prowCluChange: %i, %i \n", prowCluChange[0], prowCluChange[1]);*/ /*for(int i1=0;i1<(*pnRowClus);i1++){*/ /* Rprintf("cluster = %i, unitsCluster= %i: ", i1, ptempnUnitsRowClu[i1]);*/ /* for(int i2=0;i2<(ptempnUnitsRowClu[i1]);i2++){*/ /* Rprintf("%i ", ptemprowParArr[i1*(*pnr)+i2]);*/ /* }*/ /* Rprintf("\n");*/ /*}*/ /*Rprintf("OK2\n");*/ /* here the new partition is evaluated*/ critFun(pM, pnr, pnc, pnRel, pisTwoMode, pisSym, pdiag, pnColClus, pnRowClus, ptempnUnitsRowClu, ptempnUnitsRowClu, ptemprowParArr, ptemprowParArr, papproaches, pmaxBlockTypes, pnBlockTypeByBlock, pblocks, ptempIM, ptempEM, ptempEarr, ptemperr, pjustChange, prowCluChange, prowCluChange, psameIM, pregFun, phomFun, pusePreSpec, ppreSpecM, pcombWeights); /*Rprintf("Error after move = %.2f\n", *ptemperr);*/ /*Rprintf("Error array and blocks:\n");*/ /*int ind2d, ind3d, ind4d;*/ /*for(int iColClu=0;iColClu<*pnColClus;iColClu++){*/ /* Rprintf("\niColClu = %i\n", iColClu);*/ /* for(int iRowClu=0;iRowClu<*pnRowClus;iRowClu++){*/ /* Rprintf("iRowClu = %i\n", iRowClu);*/ /* ind2d=iColClu*(*pnRowClus) + iRowClu;*/ /* for(int iRel=0; iRel<(*pnRel);iRel++){*/ /* Rprintf("iRel = %i:\n", iRel);*/ /* ind3d= (ind2d*(*pnRel)+ iRel);*/ /* for(int iBlockType=0;iBlockType<(pnBlockTypeByBlock[ind3d]);iBlockType++){*/ /* ind4d=ind3d*(*pmaxBlockTypes)+iBlockType;*/ /* Rprintf("Blocktype = %i, err = %.5f \n", pblocks[ind4d], ptempEarr[ind4d]);*/ /* }*/ /* }*/ /* }*/ /*}*/ /*Rprintf("OK3\n");*/ if (*ptemperr< (*pbesterr)) { /* Rprintf("Error after move = %.2f\n", *ptemperr);*/ *psameErr=1; *pbesterr= *ptemperr; updateResults(pnc, pnRel, pnColClus, pnRowClus, pmaxBlockTypes, ptempnUnitsRowClu, ptemprowParArr, ptempIM, ptempEM, ptempEarr, ptemperr, pbestnUnitsRowClu, pbestrowParArr, pbestIM, pbestEM, pbestEarr, pbesterr); parArr2Vec(pnc, pnRowClus, ptempnUnitsRowClu, ptemprowParArr, pbestrowPar); for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[i] = pbestrowPar[i]; } /* Zdajle poskuam narediti tako, da bo program el ez vsa mona razbitja in shranil doloeno tevilo najboljih Torej da se zanka ne bo zakljuila, ko se bo nalo prvo bolje razbitje Pazi da bo popravil spremembe, tako tko spodaj, na zatku iteracije pa jih je potrebno ponovno udejanjiti!!! Mogoe se da kako bolje to narediti!!! */ /*Rprintf("OK4a\n");*/ /*Rprintf("################################################################\n");*/ improve=1; } else { if (*ptemperr == (*pbesterr)) { *psameErr += 1; int randTemp=randomInt(*psameErr); /* Rprintf("Error after move = %.2f\n", *ptemperr);*/ /* Rprintf("rndUpdate = %i\n", randTemp);*/ if(randTemp == 0){ updateResults(pnc, pnRel, pnColClus, pnRowClus, pmaxBlockTypes, ptempnUnitsRowClu, ptemprowParArr, ptempIM, ptempEM, ptempEarr, ptemperr, pbestnUnitsRowClu, pbestrowParArr, pbestIM, pbestEM, pbestEarr, pbesterr); parArr2Vec(pnc, pnRowClus, ptempnUnitsRowClu, ptemprowParArr, pbestrowPar); if(*psameErr <= *pmaxPar){ for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[((*psameErr)-1)*(*pnc)+i] = pbestrowPar[i]; } }else{ rnd=randomInt(*psameErr); /* Rprintf("rndOverwrite = %i\n", rnd);*/ if (rnd< *pmaxPar){ for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[rnd*(*pnc)+i] = pbestrowPar[i]; } } } } else{ parArr2Vec(pnc, pnRowClus, ptempnUnitsRowClu, ptemprowParArr, ptemprowPar); if(*psameErr <= *pmaxPar){ for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[((*psameErr)-1)*(*pnc)+i] = ptemprowPar[i]; } }else{ rnd=randomInt(*psameErr); /* Rprintf("Error after move = %.2f\n", *ptemperr);*/ /* Rprintf("rndOverwrite = %i\n", rnd);*/ if (rnd< *pmaxPar){ for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[rnd*(*pnc)+i] = ptemprowPar[i]; } } } } } } /*Rprintf("OK4b\n");*/ /* undo change found */ ptempnUnitsRowClu[iClu2]--; /* this line must be before the line below */ ptemprowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]] = prowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]]; ptemprowParArr[iClu*(*pnr)+iUnit]=prowParArr[iClu*(*pnr)+iUnit]; ptempnUnitsRowClu[iClu]++; /* this line must be after the above line */ /* temp values must be set to equal permament to be updated as needed if justChange is used*/ if(*pjustChange){ /* temp result - copy "regular" to temp - start*/ /* image matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempIM[i] = pIM[i]; } /* error matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEM[i] = pEM[i]; } /* error array by block types*/ for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEarr[i] = pEarr[i]; } /* temp result - end*/ } /*Rprintf("OK5\n");*/ } /*check the exchange of units only if iClu1 < iClu2 to avoid repeating the same move */ if(iClu < iClu2){ /* to make the order of evaluation random - start*/ /* int rndUnitsInClu2[pnUnitsRowClu[iClu2]]; for(int i=0;i0],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 sums<-apply(M, side, sum) sums[sums==0]<-1 M<-sweep(M, side, sums,FUN="/") 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/genRandomPar.R0000644000176200001440000000547313415061402015771 0ustar liggesusers"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) if(nmode==1){ mingr<-mingr[1] maxgr<-maxgr[1] find.new.par<-TRUE while(find.new.par){ ver<-sample(1:4,size=1,prob=probGenMech) if(k==n) ver<-4 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 temppar<-as.numeric(factor(temppar,levels=sample(1:k))) } } }else{ temppar<-NULL mingr<-rep(mingr,length.out=nmode) maxgr<-rep(maxgr,length.out=nmode) for(imode in 1:nmode){ find.new.par<-TRUE while(find.new.par){ ver<-sample(1:4,size=1,prob=probGenMech) 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[imode])&(max(temptab)<=maxgr[imode])){ find.new.par<-FALSE itemppar<-as.numeric(factor(itemppar,levels=sample(1:k[imode]))) } } temppar<-c(temppar,list(itemppar)) } } return(temppar) } blockmodeling/R/useneg.R0000644000176200001440000000005313370034046014673 0ustar liggesusers"useneg" <- function(x)ifelse(x<0,x,0) blockmodeling/R/sedist.R0000644000176200001440000002116613370034046014710 0ustar liggesusers"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] # "switch1" - the same as above, only that each pair occurs only once # "switch2" - an alias for switch # "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")) handle.interaction<-match.arg(handle.interaction, choices=c("switch", "switch1", "switch2", "ignore", "none")) if(handle.interaction=="switch2")handle.interaction<-"switch" 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") && use != "pairwise.complete.obs")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","switch1")){ if(fun=="cor"){ cor1<-function(...)cor(...)[1,2] fun<-"cor1" } if(fun=="cov"){ cor1<-function(...)cov(...)[1,2] fun<-"cov1" } X<-cbind(M,t(M)) 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)) } if(handle.interaction=="switch1" & fun=="dist" & !(method%in%c("maximum","binary"))) res<-res*sqrt((n-1)/n) 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=c(list(x=X, method=method,...),usearg)) } if(class(res)=="dist")attr(res,"Labels")<-rownames(M) if(is.matrix(res))dimnames(res)<-dimnames(M) return(res) } "sedistX" <- function( X, #a matrix composed of network and network transposed 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] # "switch1" - the same as above, only that each pair occurs only once # "switch2" - an alias for switch # "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")) handle.interaction<-match.arg(handle.interaction, choices=c("switch", "switch1", "switch2", "ignore", "none")) if(handle.interaction=="switch2")handle.interaction<-"switch" 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") && use != "pairwise.complete.obs")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(X)[1] if(dim(X)[2]%%n!=0) stop("The columns must be a multiple of the rows") k<-dim(X)[2]/n if(fun %in% c("cor", "cov")) usearg<-list(use=use) else usearg<-NULL #usearg if(handle.interaction %in% c("switch","switch1")){ if(fun=="cor"){ cor1<-function(...)cor(...)[1,2] fun<-"cor1" } if(fun=="cov"){ cor1<-function(...)cov(...)[1,2] fun<-"cov1" } res<-matrix(NA,ncol=n,nrow=n) for(i in 2:n)for(j in seq(length=(i-1))){ jind<-seq(length=k*n) for(l in seq(0,k-1,by = 2)){ jind[l*n+i]<-j jind[l*n+j]<-i if((l+1)0) ind.stars<-which(substr(rLines,1,1)=="*") nstars<-length(ind.stars) stars<-rLines[ind.stars] stars<-trim.trailing(stars) rm(rLines) vnames1<-read.table(file=filename,skip=ind.stars[1],nrows=ind.stars[2]-ind.stars[1]-1,as.is =TRUE) vnames<-character(n) vnames[vnames1[,1]]<-vnames1[,2] if(all(is.na(vnames))){ vnames<-NULL } else vnames[is.na(vnames)]<-"" if(is.null(useSparseMatrix)){ useSparseMatrix<- n>=50 } if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::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(requireNamespace("Matrix")){ M<-Matrix::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"|stars[i]=="*arcs"){ M[ties[,1:2]]<-ties[,3] } else if(stars[i]=="*Edges"|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 rLines<-readLines(con=filename) nl<-length(rLines) #ind.stars<-which(regexpr(pattern="*", text=rLines,fixed=TRUE)>0) ind.stars<-which(substr(rLines,1,1)=="*") nstars<-length(ind.stars) stars<-rLines[ind.stars] rm(rLines) vnames1<-read.table(file=filename,skip=ind.stars[1],nrows=ind.stars[2]-ind.stars[1]-1,as.is =TRUE) vnames<-character(n12) vnames[vnames1[,1]]<-vnames1[,2] if(all(is.na(vnames))){ vnames<-NULL } else vnames[is.na(vnames)]<-"" if(is.null(useSparseMatrix)){ useSparseMatrix<- n12>50 } if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::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/REGE.FC.R0000644000176200001440000000413613370034046014424 0ustar liggesusers"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 diag(Eall[,,1])<-1 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/REGE_for.R0000644000176200001440000003740613370034046015011 0ustar liggesusersREGE.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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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) diag(E)<-1.0 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/Cinterfaces.R0000644000176200001440000011516113621550310015636 0ustar liggesusers# to do - here and in C-functions --> put functional blocks before regular !!! cStatus<-list( blockTypes=c("nul", "com", "cfn", "rfn", "reg", "cre", "rre", "avg", "dnc"), #add before average regFuns=c("max","sum","mean"), homFuns=c("ss", "ad"), implementedApproaches=c("hom", "bin","val") # ,maxBlockTypes=as.integer(10) ) # zgornje spremenljivke morajo biti enake kot v C-ju (blockmodeling.c) allInDimEqual<-function(arr,d)all(apply(arr,d,function(x){x<-as.vector(x);all(x==x[1])})) clu2parArr<-function(clu){ if(!is.list(clu))clu<-list(clu,clu) nrc<-sapply(clu,length) clu<-lapply(clu,function(x)as.integer(as.factor(x))) nUnitsInRCclu<-lapply(clu,function(x)as.integer(table(x))) nRCclu<-sapply(nUnitsInRCclu,length) rowParArr<-matrix(as.integer(0),nrow=nrc[1],ncol=nRCclu[1]) for(i in clu[[1]]){ rowParArr[1:nUnitsInRCclu[[1]][i],i]<-as.integer(which(clu[[1]]==i)-1) } colParArr<-matrix(as.integer(0),nrow=nrc[2],ncol=nRCclu[2]) for(i in clu[[2]]){ colParArr[1:nUnitsInRCclu[[2]][i],i]<-as.integer(which(clu[[2]]==i)-1) } return(list(rowParArr=rowParArr,colParArr=colParArr,nUnitsInRCclu=nUnitsInRCclu, nRCclu=nRCclu, nrc=nrc)) } parArr2clu<-function(nUnitsRowClu, nUnitsColClu, rowParArr, colParArr, nColClus=NULL, nRowClus=NULL){ clu<-list(parArrOne2clu(nUnitsClu=nUnitsRowClu, parArr=rowParArr, nClus=nRowClus),parArrOne2clu(nUnitsClu=nUnitsColClu, parArr=colParArr, nClus=nColClus)) } parArrOne2clu<-function(nUnitsClu, parArr,nClus=NULL){ if(is.null(nClus)){ nClus<-dim(parArr)[2] } else { if(nClus!=dim(parArr)[2]) warning("Number of clusters and dimmension of the partition array do not match") } n<-sum(nUnitsClu) clu<-rep(NA,n) for(i in 1:nClus){ clu[parArr[(1:nUnitsClu[i]),i]+1]<-i } return(clu) } IMaddNames<-function(IM){ array(factor(IM+1,labels=cStatus$blockTypes,levels=1:length(cStatus$blockTypes)),dim=dim(IM)) } formatPreSpecM<-function(preSpecMorg,dB,blocks){ if(is.null(preSpecMorg)){ preSpecM <- array(as.double(NA),dim=dB) } else if (is.vector(preSpecMorg)){ if(length(preSpecMorg)==1){ preSpecM <- array(as.double(preSpecMorg),dim=dB) } else if(length(preSpecMorg)==dB[2]){ preSpecM <- array(as.double(NA),dim=dB) for(i in 1:dB[2]){ preSpecM[,i,,]<-as.double(preSpecMorg[i]) } } else if((dB[2]==1) & (length(preSpecMorg)==dB[1]) & allInDimEqual(blocks,1)){ preSpecM <- array(as.double(NA),dim=dB) for(i in 1:dB[1]){ preSpecM[i,,,]<-as.double(preSpecMorg[i]) } } else stop("'",deparse(substitute(preSpecMorg)),"' is a vector with unexpected length") } else if(is.array(preSpecMorg)){ preSpecM <- array(as.double(preSpecMorg),dim=dim(preSpecMorg)) if(any(dim(preSpecM)!=dB)){ stop("dimensions of '",deparse(substitute(preSpecMorg)),"' and 'blocks' do not match") } } return(preSpecM) } computeCombWeights<-function(combWeights, dB, blocks, relWeights, posWeights, blockTypeWeights){ if(!is.null(combWeights)){ if(all(dim(combWeights)==dB)){ combWeights<-array(as.double(combWeights),dim=dim(combWeights)) return(combWeights) } warning("Dimmensions of the combWeights does not match the dimmensions of blocks!\nIt will not be used!\nIf possible it will be computed using other weights!") } combWeights<-array(as.double(1),dim=dB) relWeights<-as.double(relWeights) if(length(relWeights)!=dB[2]){ if(length(relWeights)==1) relWeights<-rep(relWeights,dB[2]) else stop("To relWeights should have length equal to the number of relations!") } for(i in 1:dB[2]){ combWeights[,i,,]<-combWeights[,i,,]*relWeights[i] } if(all(dim(posWeights)!=dB[3:4])){ if(length(posWeights)==1) posWeights<-array(posWeights,dim=dB[3:4]) else stop("To posWeights should have the same dimensions as block image!") } posWeights<-array(as.double(posWeights), dim=dim(posWeights)) for(i in 1:dB[3]){ for(j in 1:dB[4]){ combWeights[,,i,j]<-combWeights[,,i,j]*posWeights[i,j] } } if(!(is.numeric(blockTypeWeights)&all(names(blockTypeWeights)%in%cStatus$blockTypes))) stop("blockTypeWeights must be a numeric named vector with names from: ", paste(cStatus$blockTypes, collapse=", ")) for(i in names(blockTypeWeights)){ tWhich <- blocks==i tWhich[is.na(tWhich)]<-FALSE combWeights[tWhich]<-blockTypeWeights[i]* combWeights[tWhich] } return(combWeights) } formatUsePreSpecM<-function(usePreSpecMorg,preSpecM,dB,blocks){ if(is.null(usePreSpecMorg)){ usePreSpecM<- !is.na(preSpecM) }else if(is.vector(usePreSpecMorg)){ if(length(usePreSpecMorg)==dB[2]){ usePreSpecM <- array(as.integer(NA),dim=dB) for(i in 1:dB[2]){ usePreSpecM[,i,,]<-as.integer(usePreSpecMorg[i]) } } else if((dB[2]==1) & (length(usePreSpecMorg)==dB[1]) & allInDimEqual(blocks,1)){ usePreSpecM <- array(as.integer(NA),dim=dB) for(i in 1:dB[1]){ usePreSpecM[i,,,]<-as.integer(usePreSpecMorg[i]) } } else stop("'",deparse(substitute(usePreSpecM)),"' is a vector with unexpected length") } else if(is.array(usePreSpecMorg)){ if(any(dim(usePreSpecMorg)!=dB)){ stop("dimensions of '",deparse(substitute(usePreSpecM)),"' and 'blocks' do not match") } usePreSpecM <- array(as.integer(usePreSpecMorg),dim=dim(usePreSpecMorg)) } return(usePreSpecM) } ########## warning -- this functions needs to be corrected to be more similar to optParC and optRandParC critFunC<-function(M, clu, approaches, blocks, isTwoMode = NULL, isSym = NULL, diag = 1, IM = NULL, EM = NULL, Earr = NULL, justChange = FALSE, rowCluChange = c(0, 0), colCluChange = c(0, 0), sameIM = FALSE, regFun = "max", homFun = "ss", usePreSpecM = NULL, preSpecM = NULL, save.initial.param = TRUE, relWeights = 1, posWeights = 1, blockTypeWeights = 1, combWeights = NULL, returnEnv = FALSE){ 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 if(length(dim(M))==2) M<-array(M,dim=c(dim(M),length(approaches))) #M[,,approaches=="bin"]<-(M[,,approaches=="bin"]>0)*1 dM<-dim(M) if(is.null(isTwoMode)) isTwoMode<-is.list(clu) if(!is.list(clu))clu<-list(clu,clu) orgClu<-clu clu<-lapply(clu,function(x)as.integer(as.factor(x))) nUnitsInRCclu<-lapply(clu,function(x)as.integer(table(x))) nRCclu<-sapply(nUnitsInRCclu,length) # if(is.null(nMode)) nMode<-ifelse(is.list(clu),length(clu),1) # if(nMode>1){ # tmNclu<-sapply(clu,max) # for(iMode in 2:nMode){ # clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) # } # clu<-unlist(clu) # } rowParArr<-matrix(as.integer(0),nrow=dM[1],ncol=nRCclu[1]) for(i in 1:nRCclu[[1]]){ rowParArr[1:nUnitsInRCclu[[1]][i],i]<-as.integer(which(clu[[1]]==i)-1) } colParArr<-matrix(as.integer(0),nrow=dM[2],ncol=nRCclu[2]) for(i in 1:nRCclu[[2]]){ colParArr[1:nUnitsInRCclu[[2]][i],i]<-as.integer(which(clu[[2]]==i)-1) } if(is.null(isSym)){ isSym<-integer(dM[3]) if(isTwoMode) { isSym[]<-FALSE } else { for(i in 1:dM[3]) isSym[i]<-all(M[,,i]==t(M[,,i])) } } else if(length(isSym)==1) isSym<-rep(isSym, dM[3]) if(isTwoMode)diag<-FALSE if(length(diag)!=dM[3]) diag<-rep(diag[1], dM[3]) if(length(approaches)!=dM[3]&&(length(approaches)==1)) approaches<-rep(approaches[1], dM[3]) if(is.list(blocks)){ if(length(blocks)!=dM[3]) stop("the number of relations implied by 'blocks' and by 'M' does not match") maxBlockTypes<- max(sapply(blocks,length)) blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) for(i in 1:dM[3]){ nBT<-length(blocks[[i]]) blocksArr[1:nBT,i,,]<-array(blocks[[i]],dim=c(nBT,nRCclu)) } blocks <- blocksArr } else if(is.vector(blocks)){ maxBlockTypes<-length(blocks) blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) blocksArr[1:length(blocks),,,]<-blocks blocks <- blocksArr } else if(!is.array(blocks)){ stop("'blocks' argument should be a vector, a list or an array with appropriate dimmensions") }else { if(length(dim(blocks))==4){ maxBlockTypes<-dim(blocks)[1] if(any(dim(blocks)!=c(maxBlockTypes,dM[3],nRCclu))) stop("array ('blocks' argument) has a wrong dimensions of dimmensions") } else if(length(dim(blocks))==3){ maxBlockTypes<-dim(blocks)[1] blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) for(i in 1:dM[3]){ blocksArr[,i,,]<-blocks } blocks <- blocksArr } else if(length(dim(blocks))==2){ maxBlockTypes<-1 blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) for(i in 1:dM[3]){ blocksArr[1,i,,]<-blocks } blocks <- blocksArr } else stop("array ('blocks' argument) has a wrong number of dimmensions") } dB<-dim(blocks) if(dB[2]!=dM[3])stop("the number of relations implied by 'blocks' and by 'M' does not match") if(!all(dB[3:4]==nRCclu))stop("number of clusters implied by 'blocks' and by 'clu' does not match") nBlockTypeByBlock<-apply(!is.na(blocks),c(2,3,4),sum) blocks[blocks=="null"]<-"nul" blocks[blocks=="den"]<-"avg" if(is.null(IM)){ IM<-array(as.integer(99),dim=dB[2:4]) }else if (length(dim(IM))==2){ IM<-array(as.integer(factor(IM,levels=cStatus$blockTypes))-as.integer(1),dim=c(dM[3],nRCclu)) }else{ IM<-array(as.integer(factor(IM,levels=cStatus$blockTypes))-as.integer(1),dim=dim(IM)) } if(is.null(EM)){ EM<-array(as.double(Inf),dim=dB[2:4]) } else EM<-array(as.double(EM),dim=dim(EM)) if(is.null(Earr)){ Earr<-array(as.double(Inf),dim=dB) }else Earr<-array(as.double(Earr),dim=dim(Earr)) if(length(homFun)==1 & dM[3]>1) homFun<-rep(homFun,dM[3]) homFun[approaches=="ss"]<-"ss" homFun[approaches=="ad"]<-"ad" approaches[approaches%in%c("ss","ad")]<-"hom" homFun<-as.integer(factor(homFun,levels=cStatus$homFuns))-as.integer(1) regFun<-as.integer(factor(regFun,levels=cStatus$regFuns))-as.integer(1) if(is.vector(regFun)){ if(length(regFun)==1){ regFun <- array(as.integer(regFun),dim=dB) }else if (dB[2]==1){ if(length(regFun)==dB[1]){ regFunArr <- array(as.integer(NA),dim=dB) regFunArr[,,,]<-regFun regFun<-regFunArr } else stop("'regFun' is a vector of unapropriate length") } else if(length(regFun)==dB[2]){ regFunArr <- array(as.integer(NA),dim=dB) regFunArr[,,,]<-regFun regFun<-regFunArr } else stop("'regFun' is a vector of unapropriate length") } else if(is.array(regFun)){ if(dim(regFun)!=dB){ stop("'regFun' is an array - dimensions of 'regFun' and 'blocks' do not match") } } else stop("'regFun' is neither a vector or an array") preSpecM<-formatPreSpecM(preSpecMorg=preSpecM,dB=dB,blocks=blocks) usePreSpecM<-formatUsePreSpecM(usePreSpecMorg=usePreSpecM,preSpecM=preSpecM,dB=dB,blocks=blocks) if(any(approaches=="bin") && (!all(M[,,approaches=="bin"] %in% c(0,1)))){ for(i in 1:length(approaches)){ if(approaches[i]=="bin"){ if(!all(M[,,i] %in% c(0,1))){ tmpPreSpecM<-preSpecM[,i,,] if(all(is.na(tmpPreSpecM))){ M[,,i]<-(M[,,i]>0)*1 } else if(all(tmpPreSpecM==tmpPreSpecM[1,1,1])){ M[,,i]<-(M[,,i]>=tmpPreSpecM[1,1,1])*1 } else stop("Relation ",i," is not binary but suplied to binary blockmodeling without suitable value in 'preSpecM'!",sep="") } } } } approaches <- as.integer(factor(approaches,levels=cStatus$implementedApproaches))-as.integer(1) combWeights<-computeCombWeights(combWeights, dB, blocks, relWeights, posWeights, blockTypeWeights) blocks<-array(as.integer(factor(blocks,levels=cStatus$blockTypes)),dim=dim(blocks))-as.integer(1) M<-apply(M,c(2,3),as.double) resC<-.C("critFun", M=M, nr=dM[1], nc=dM[2], nRel=dM[3], isTwoMode=as.integer(isTwoMode), isSym=as.integer(isSym), diag=as.integer(diag), nColClus=nRCclu[2], nRowClus=nRCclu[1], nUnitsRowClu=nUnitsInRCclu[[1]], nUnitsColClu=nUnitsInRCclu[[2]], rowParArr=rowParArr, colParArr=colParArr, approaches=approaches, maxBlockTypes=as.integer(maxBlockTypes), nBlockTypeByBlock=array(as.integer(nBlockTypeByBlock),dim=dim(nBlockTypeByBlock)), blocks=blocks, IM=IM, EM=EM, Earr=Earr, err=sum(EM), justChange=as.integer(justChange), rowCluChange=as.integer(rowCluChange), colCluChange=as.integer(colCluChange), sameIM=as.integer(sameIM), regFun=regFun, homFun=homFun, usePreSpec=usePreSpecM, preSpecM=preSpecM,combWeights=combWeights,NAOK=TRUE) res<-c(list(M=M), resC[c("err","EM","Earr")], list(IM=IMaddNames(resC$IM)), list(clu=orgClu), initial.param, list(call=match.call()), if(returnEnv)list(env= environment()) else NULL) class(res)<-"crit.fun" return(res) } optParC<-function(M, clu, approaches, blocks, nMode=NULL,isSym=NULL,diag=1, useMulti=FALSE, maxPar=50, IM=NULL,EM=NULL,Earr=NULL, justChange=TRUE, sameIM=FALSE, regFun="max", homFun = "ss", usePreSpecM = NULL, preSpecM=NULL, minUnitsRowCluster = 1, minUnitsColCluster = 1, maxUnitsRowCluster = 9999, maxUnitsColCluster = 9999, relWeights=1, posWeights=1, blockTypeWeights=1,combWeights=NULL, exchageClusters="all",save.initial.param=TRUE){ 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 if(length(dim(M))==2) M<-array(M,dim=c(dim(M),length(approaches))) dM<-dim(M) if(is.null(nMode)) nMode<-ifelse(is.list(clu),length(clu),1) if(nMode>1){ tmN<-sapply(clu,length) clu<-lapply(clu,function(x)as.integer(as.factor(x))) tmNclu<-sapply(clu,max) for(iMode in 2:nMode){ clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) } clu<-unlist(clu) if(dM[1]!=length(clu)|dM[2]!=length(clu)){ warning("Two (and more) mode networks implemented through one mode networks!\nOnly partition, network and blocks arguments are converted if needed!\nIf usePrespecVal and similar arguments are arrays they must be in appropriate format - one mode network with two-mode network in upper right quadrant") #currently two mode networks are treated as a special case of one mode networks where 3 "quadrants" of the network are filled with zeros oldM<-M oldDM<-dim(oldM) nUnitsTmp<-length(clu) M<-array(0,dim=c(nUnitsTmp,nUnitsTmp,length(approaches))) M[1:oldDM[1],((oldDM[1]+1):nUnitsTmp),]<-oldM dM<-dim(M) } } if(!is.list(clu))clu<-list(clu,clu) clu<-lapply(clu,function(x)as.integer(as.factor(x))-as.integer(1)) nUnitsInRCclu<-lapply(clu,function(x)as.integer(table(x))) nRCclu<-sapply(nUnitsInRCclu,length) rowParArr<-matrix(as.integer(0),nrow=dM[1],ncol=nRCclu[1]) for(i in 1:nRCclu[1]){ rowParArr[1:nUnitsInRCclu[[1]][i],i]<-as.integer(which(clu[[1]]==(i-1))-1) } colParArr<-matrix(as.integer(0),nrow=dM[2],ncol=nRCclu[2]) for(i in 1:nRCclu[2]){ colParArr[1:nUnitsInRCclu[[2]][i],i]<-as.integer(which(clu[[2]]==(i-1))-1) } if(exchageClusters=="all"){ if(nMode>1){ exchageClusters=matrix(as.integer(0),nrow=nRCclu[1],ncol=nRCclu[2]) tmp<-c(0,tmNclu) for(imodeNclu in seq_along(tmNclu)){ tmpInd<-(sum(tmp[1:imodeNclu])+1):sum(tmNclu[1:imodeNclu]) exchageClusters[tmpInd,tmpInd]=as.integer(1) } } else{ exchageClusters=matrix(as.integer(1),nrow=nRCclu[1],ncol=nRCclu[2]) } } if(is.null(isSym)){ isSym<-integer(dM[3]) for(i in 1:dM[3]) isSym[i]<-all(M[,,i]==t(M[,,i])) } else if(length(isSym)==1) isSym<-rep(isSym, dM[3]) #if(isTwoMode)diag<-FALSE #not needed as two mode netowrks are implemented through one-mode networks if(length(diag)!=dM[3]) diag<-rep(diag[1], dM[3]) if(length(approaches)!=dM[3]&&(length(approaches)==1)) approaches<-rep(approaches[1], dM[3]) if(is.list(blocks)){ if(length(blocks)!=dM[3]) stop("the number of relations implied by 'blocks' and by 'M' does not match") maxBlockTypes<- max(sapply(blocks,length)) blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) for(i in 1:dM[3]){ nBT<-length(blocks[[i]]) blocksArr[1:nBT,i,,]<-array(blocks[[i]],dim=c(nBT,nRCclu)) } blocks <- blocksArr } else if(is.vector(blocks)){ maxBlockTypes<-length(blocks) blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) blocksArr[1:length(blocks),,,]<-blocks blocks <- blocksArr } else if(!is.array(blocks)){ stop("'blocks' argument should be a vector, a list or an array with appropriate dimmensions") }else { if(length(dim(blocks))==4){ maxBlockTypes<-dim(blocks)[1] if(any(dim(blocks)!=c(maxBlockTypes,dM[3],nRCclu))){ if(nMode==2){ oldBlocks<-blocks blocks<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) blocks[,,1:tmNclu[1],(tmNclu[1]+1):sum(tmNclu)]<-oldBlocks blocks[1,,(tmNclu[1]+1):sum(tmNclu),]<-"dnc" blocks[1,,1:tmNclu[1],1:tmNclu[1]]<-"dnc" if(any(dim(blocks)!=c(maxBlockTypes,dM[3],nRCclu))) stop("array ('blocks' argument) has a wrong dimensions of dimensions") } else stop("array ('blocks' argument) has a wrong dimensions of dimensions") } } else if(length(dim(blocks))==3){ maxBlockTypes<-dim(blocks)[1] blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) if(nMode==2){ for(i in 1:dM[3]){ blocksArr[,i,1:tmNclu[1],(tmNclu[1]+1):sum(tmNclu)]<-blocks } } else { for(i in 1:dM[3]){ blocksArr[,i,,]<-blocks } } blocks <- blocksArr if(nMode==2){ blocks[1,,(tmNclu[1]+1):sum(tmNclu),]<-"dnc" blocks[1,,1:tmNclu[1],1:tmNclu[1]]<-"dnc" } } else if(length(dim(blocks))==2){ maxBlockTypes<-1 blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) if(nMode==2){ for(i in 1:dM[3]){ blocksArr[1,i,1:tmNclu[1],(tmNclu[1]+1):sum(tmNclu)]<-blocks } }else { for(i in 1:dM[3]){ blocksArr[1,i,,]<-blocks } } blocks<-blocksArr if(nMode==2){ blocks[1,,(tmNclu[1]+1):sum(tmNclu),]<-"dnc" blocks[1,,1:tmNclu[1],1:tmNclu[1]]<-"dnc" } } else stop("array ('blocks' argument) has a wrong number of dimmensions") } dB<-dim(blocks) if(dB[2]!=dM[3])stop("the number of relations implied by 'blocks' and by 'M' does not match") if(!all(dB[3:4]==nRCclu))stop("number of clusters implied by 'blocks' and by 'clu' does not match") nBlockTypeByBlock<-apply(!is.na(blocks),c(2,3,4),sum) blocks[blocks=="null"]<-"nul" blocks[blocks=="den"]<-"avg" if(is.null(IM)){ IM<-array(as.integer(99),dim=dB[2:4]) }else if (length(dim(IM))==2){ IM<-array(as.integer(factor(IM,levels=cStatus$blockTypes))-as.integer(1),dim=c(dM[3],nRCclu)) }else{ IM<-array(as.integer(factor(IM,levels=cStatus$blockTypes))-as.integer(1),dim=dim(IM)) } if(is.null(EM)){ EM<-array(as.double(Inf),dim=dB[2:4]) } else EM<-array(as.double(EM),dim=dim(EM)) if(is.null(Earr)){ Earr<-array(as.double(Inf),dim=dB) }else Earr<-array(as.double(Earr),dim=dim(Earr)) if(length(homFun)==1 & dM[3]>1) homFun<-rep(homFun,dM[3]) homFun[approaches=="ss"]<-"ss" homFun[approaches=="ad"]<-"ad" approaches[approaches%in%c("ss","ad")]<-"hom" homFun<-as.integer(factor(homFun,levels=cStatus$homFuns))-as.integer(1) regFun<-as.integer(factor(regFun,levels=cStatus$regFuns))-as.integer(1) if(is.vector(regFun)){ if(length(regFun)==1){ regFun <- array(as.integer(regFun),dim=dB) }else if (dB[2]==1){ if(length(regFun)==dB[1]){ regFunArr <- array(as.integer(NA),dim=dB) regFunArr[,,,]<-regFun regFun<-regFunArr } else stop("'regFun' is a vector of unapropriate length") } else if(length(regFun)==dB[2]){ regFunArr <- array(as.integer(NA),dim=dB) regFunArr[,,,]<-regFun regFun<-regFunArr } else stop("'regFun' is a vector of unapropriate length") } else if(is.array(regFun)){ if(dim(regFun)!=dB){ stop("'regFun' is an array - dimensions of 'regFun' and 'blocks' do not match") } } else stop("'regFun' is neither a vector or an array") preSpecM<-formatPreSpecM(preSpecMorg=preSpecM,dB=dB,blocks=blocks) usePreSpecM<-formatUsePreSpecM(usePreSpecMorg=usePreSpecM,preSpecM=preSpecM,dB=dB,blocks=blocks) if(any(approaches=="bin") && (!all(M[,,approaches=="bin"] %in% c(0,1)))){ for(i in 1:length(approaches)){ if(approaches[i]=="bin"){ if(!all(M[,,i] %in% c(0,1))){ tmpPreSpecM<-preSpecM[,i,,] if(all(is.na(tmpPreSpecM))){ M[,,i]<-(M[,,i]>0)*1 } else if(all(tmpPreSpecM==tmpPreSpecM[1,1,1])){ M[,,i]<-(M[,,i]>=tmpPreSpecM[1,1,1])*1 } else stop("Relation ",i," is not binary but suplied to binary blockmodeling without suitable value in 'preSpec'!",sep="") } } } } approaches <- as.integer(factor(approaches,levels=cStatus$implementedApproaches))-as.integer(1) M<-apply(M,c(2,3),as.double) combWeights<-computeCombWeights(combWeights, dB, blocks, relWeights, posWeights, blockTypeWeights) blocks<-array(as.integer(factor(blocks,levels=cStatus$blockTypes)),dim=dim(blocks))-as.integer(1) if(useMulti){ bestColParMatrix <- matrix(as.integer(NA),ncol=maxPar,nrow=dM[2]) bestRowParMatrix <- matrix(as.integer(NA),ncol=maxPar,nrow=dM[1]) resC<-.C("optParMulti", M=M, nr=dM[1], nc=dM[2], nRel=dM[3], isTwoMode= 0 #as.integer(isTwoMode) - two mode networks are currently implemented through onemode networks , isSym=as.integer(isSym), diag=as.integer(diag), nColClus=nRCclu[2], nRowClus=nRCclu[1], nUnitsRowClu=nUnitsInRCclu[[1]], nUnitsColClu=nUnitsInRCclu[[2]], rowPar=clu[[1]], colPar=clu[[2]], rowParArr=rowParArr, colParArr=colParArr, approaches=approaches, maxBlockTypes=as.integer(maxBlockTypes), nBlockTypeByBlock=array(as.integer(nBlockTypeByBlock),dim=dim(nBlockTypeByBlock)), blocks=blocks, IM=IM, EM=EM, Earr=Earr, err=sum(EM), justChange=as.integer(justChange), rowCluChange=integer(2), colCluChange=integer(2), sameIM=as.integer(sameIM), regFun=regFun, homFun=homFun, usePreSpec=usePreSpecM, preSpecM=preSpecM, minUnitsRowCluster = as.integer(minUnitsRowCluster), minUnitsColCluster = as.integer(minUnitsColCluster), maxUnitsRowCluster = as.integer(maxUnitsRowCluster), maxUnitsColCluster = as.integer(maxUnitsColCluster), sameErr=as.integer(0), nIter=as.integer(0),combWeights=combWeights, exchageClusters=exchageClusters, maxPar=as.integer(maxPar), bestColParMatrix=bestColParMatrix, bestRowParMatrix=bestRowParMatrix, NAOK=TRUE) clu<- resC$rowPar } else{ resC<-.C("optPar", M=M, nr=dM[1], nc=dM[2], nRel=dM[3], isTwoMode= 0 #as.integer(isTwoMode) - two mode networks are currently implemented through onemode networks , isSym=as.integer(isSym), diag=as.integer(diag), nColClus=nRCclu[2], nRowClus=nRCclu[1], nUnitsRowClu=nUnitsInRCclu[[1]], nUnitsColClu=nUnitsInRCclu[[2]], rowParArr=rowParArr, colParArr=colParArr, approaches=approaches, maxBlockTypes=as.integer(maxBlockTypes), nBlockTypeByBlock=array(as.integer(nBlockTypeByBlock),dim=dim(nBlockTypeByBlock)), blocks=blocks, IM=IM, EM=EM, Earr=Earr, err=sum(EM), justChange=as.integer(justChange), rowCluChange=integer(2), colCluChange=integer(2), sameIM=as.integer(sameIM), regFun=regFun, homFun=homFun, usePreSpec=usePreSpecM, preSpecM=preSpecM, minUnitsRowCluster = as.integer(minUnitsRowCluster), minUnitsColCluster = as.integer(minUnitsColCluster), maxUnitsRowCluster = as.integer(maxUnitsRowCluster), maxUnitsColCluster = as.integer(maxUnitsColCluster), sameErr=as.integer(0), nIter=as.integer(0),combWeights=combWeights,exchageClusters=exchageClusters, NAOK=TRUE) clu<- parArrOne2clu(nUnitsClu=resC$nUnitsRowClu, parArr=resC$rowParArr, nClus=resC$nRowClus) } # if(isTwoMode){ # not needed as two-mode networks are implementer through onemode networks # clu<- list( # parArrOne2clu(nUnitsClu=resC$nUnitsRowClu, parArr=resC$rowParArr, nClus=resC$nRowClus), # parArrOne2clu(nUnitsClu=resC$nUnitsColClu, parArr=resC$colParArr, nClus=resC$nColClus) # ) # } else { # This (under else) is moved up in to the if(useMulti), as it differs for both functions optPar C functions. Most likely, the below code could be used for both, but is not tested. # clu<- parArrOne2clu(nUnitsClu=resC$nUnitsRowClu, parArr=resC$rowParArr, nClus=resC$nRowClus) # } # this is new and experimental if(nMode>1){ clu<-split(clu, f = rep(1:length(tmN),times=tmN)) clu<-lapply(clu,function(x)as.integer(as.factor(x))) tmNclu<-sapply(clu,max) for(iMode in 2:nMode){ clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) } } else clu<-as.integer(as.factor(clu)) res<-c(list(M=M), resC[c("err","EM","Earr","sameErr")], list(IM=IMaddNames(resC$IM)), clu=list(clu), initial.param, list(call=match.call()),if(useMulti)list(bestRowParMatrix=bestRowParMatrix),list(resC=resC)) class(res)<-"optPar" return(res) } "optRandomParC" <-function(M, k,#number of clusters/groups approaches, #generalized blockmodeling approach blocks, #allowed block types as a vector, list or array. rep,#number of repetitions/different starting partitions to check save.initial.param=TRUE, #save the initial parametrs of this call save.initial.param.opt=FALSE, #save the initial parametrs for calls to optParC deleteMs=TRUE, #delete networks/matrices from results of optParC 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) switch.names=NULL,#should partitions that only differ in group names be considert equal (is c(1,1,2)==c(2,2,1)) 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 seed=NULL,#the seed for random generation of partitions RandomSeed=NULL, # the state of .Random.seed (e.g. as saved previously). Should not be "typed" by the user 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=NULL, #minimal alowed group size (defaults to c(minUnitsRowCluster,minUnitsColCluster) if set, else to 1) - only used for parGenFun function maxgr=NULL, #maximal alowed group size (default to c(maxUnitsRowCluster,maxUnitsColCluster) if set, else to Inf) - only used for parGenFun function 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 skip.par = NULL, #partitions to be skiped useOptParMultiC = FALSE, # For backward compatibility. May be removed soon. See next argumetent. useMulti = useOptParMultiC, #Should the "Multi" vesrsion of the optParC functions be used? Defaults to FALSE, which is usually faster, but in a sense not so thorough. printRep= ifelse(rep<=10,1,round(rep/10)), #should some information about each optimization be printed n=NULL, #the number of units by "modes". It is used only for generating random partitions. It has to be set only if there are more than two modes or if there are two modes, but the matrix representing the network is onemode (both modes are in rows and columns) nCores=1, #number of cores to be used 0 -means all available cores, can also be a cluster object ... #paramters to optParC ){ dots<-list(...) #this might not be need - can be removed and all latter occurencies given sufficent testing. Left for now as there is not enought time. if(is.null(switch.names)){ switch.names<-is.null(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 if(is.null(mingr)){ if(is.null(dots$minUnitsRowCluster)){ mingr<-1 } else { mingr<-c(dots$minUnitsRowCluster,dots$minUnitsColCluster) } } if(is.null(maxgr)){ if(is.null(dots$maxUnitsRowCluster)){ maxgr<-Inf } else { maxgr<-c(dots$maxUnitsRowCluster,dots$maxUnitsColCluster) } } nmode<-length(k) res<-list(NULL) err<-NULL nIter<-NULL if(is.null(n)) if(nmode==1){ n<-dim(M)[1] } else if(nmode==2){ n<-dim(M)[1:2] } else warning("Number of nodes by modes can not be determined. Parameter 'n' must be supplied!!!") if(!is.null(RandomSeed)){ .Random.seed <- RandomSeed } else 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]]$clu)==1), !any(sapply(best.clu,function(x)all(x==res1[[i]]$clu))) ) else ifelse(switch.names, !any(sapply(best.clu,function(x,clu2)rand2(unlist(x),clu2),clu2=unlist(res1[[i]]$clu))==1), !any(sapply(best.clu,function(x)all(unlist(x)==unlist(res1[[i]]$clu)))) ) ) ){ best<-c(best,res1[i]) best.clu<-c(best.clu,list(res1[[i]]$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, list(Random.seed=.Random.seed)) class(res)<-"opt.more.par" return(res) }) if(nCores==1||!requireNamespace("doParallel")||!requireNamespace("doRNG")){ if(nCores!=1) { oldWarn<-options("warn") options(warn=1) warning("Only single core is used as package 'doParallel' or 'doRNG' (or both) is/are not available") options(oldWarn) } for(i in 1:rep){ if(printRep & (i%%printRep==0)) 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,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 skip.par<-c(skip.par,list(temppar)) if(printRep==1) cat("Starting partition:",unlistPar(temppar),"\n") #if(useOptParMultiC){ # res[[i]]<-optParMultiC(M=M, clu=temppar, save.initial.param= save.initial.param.opt, ...) #}else res[[i]]<-optParC(M=M, clu=temppar, save.initial.param= save.initial.param.opt, ...) res[[i]]<-optParC(M=M, clu=temppar, approaches=approaches, blocks=blocks, useMulti=useMulti, save.initial.param= save.initial.param.opt, ...) if(deleteMs){ res[[i]]$M<-NULL res[[i]]$resC$M<-NULL } err[i]<-res[[i]]$err nIter[i]<-res[[i]]$resC$nIter if(printRep==1) cat("Final error:",err[i],"\n") if(printRep==1) cat("Final partition: ",unlistPar(res[[i]]$clu),"\n") } } else { requireNamespace("doParallel") requireNamespace("doRNG") `%dorng%`<-doRNG::`%dorng%` if(!foreach::getDoParRegistered()){ if(nCores==0){ nCores<-detectCores()-1 } doParallel::registerDoParallel(nCores) } nC<-foreach::getDoParWorkers() oneRep<-function(i,M,approaches, blocks, n,k,mingr,maxgr,addParam,rep,nC,...){ if(printRep) cat("\n\nStarting optimization of the partiton",i,"of",rep,"partitions.\n") temppar<-parGenFun(n=n,k=k,mingr=mingr,maxgr=maxgr,addParam=addParam) #skip.par<-c(skip.par,list(temppar)) #if(useOptParMultiC){ # tres <- try(optParMultiC(M=M, clu=temppar, save.initial.param= save.initial.param.opt, ...)) #}else tres <- try(optParC(M=M, clu=temppar, save.initial.param= save.initial.param.opt, ...)) tres <- try(optParC(M=M, clu=temppar, approaches=approaches, blocks=blocks, useMulti=useMulti, save.initial.param= save.initial.param.opt, ...)) if(class(tres)=="try-error"){ tres<-list("try-error"=tres, err=Inf, nIter=Inf, startPart=temppar) } if(deleteMs){ tres$M<-NULL tres$resC$M<-NULL } # err[i]<-res[[i]]$err # nIter[i]<-res[[i]]$resC$nIter return(list(tres)) } pkgName<-utils::packageName() res<-foreach::foreach(i=1:rep,.combine=c, .packages=pkgName) %dorng% oneRep(i=i,M=M,approaches=approaches, blocks=blocks ,n=n,k=k,mingr=mingr,maxgr=maxgr,addParam=addParam,rep=rep,nC=nC,...) err<-sapply(res,function(x)x$err) nIter<-sapply(res,function(x)x$resC$nIter) } } unlistPar<-function(part){ if(is.list(part)){ part<-sapply(part,paste,collapse=" ") part<-paste(paste("\nMode ", 1:length(part),":",sep=""), part,collapse="",sep=" ") } part } parArr2VecC<-function(parArr,nUnitsClu=NULL){ if(is.null(nUnitsClu)){ nUnitsClu<-apply(parArr,2,function(x)sum(!is.na(x))) } n<-sum(nUnitsClu) nClus <- length(nUnitsClu) if(!is.integer(parArr)){ parArr<-apply(parArr,2,as.integer) } resC<-.C("parArr2Vec",n=as.integer(n), nClus = nClus, nUnitsClu=as.integer(nUnitsClu),parArr=parArr, parVec=integer(n), NAOK=TRUE) return(resC$parVec) } parVec2ArrC<-function(parVec){ n<-length(parVec) parVec<-as.integer(as.factor(parVec))- as.integer(1) nClus <- as.integer(max(parVec)+1) nUnitsClu<-integer(nClus) parArr<-matrix(NA,ncol=nClus,nrow=n) parArr<-apply(parArr,2,as.integer) resC<-.C("parVec2Arr",n=n, nClus = nClus, nUnitsClu=nUnitsClu,parArr=parArr, parVec=parVec, NAOK=TRUE) parArr<-resC$parArr return(parArr) } blockmodeling/R/loadvector.R0000644000176200001440000000060113370034046015546 0ustar liggesusers"loadvector" <- structure(function(filename){ i=0 repeat { n<-read.table(file=filename,nrows=1,as.is=TRUE,skip = i) if(substr(n[1],1,1)!="%") break print(paste(n,collapse=" ")) i=i+1 } vv<-read.table(file=filename,skip=1+i,as.is=TRUE) if (dim(vv)[2]==1) vv<-vv[[1]] vv } , comment = "Load vector(s) from file that was produced by Pajek") blockmodeling/R/fun.by.blocks.R0000644000176200001440000000010313370034046016056 0ustar liggesusers"fun.by.blocks" <- function(x, ...) UseMethod("fun.by.blocks") blockmodeling/R/loadmatrix.R0000644000176200001440000000147313370034046015560 0ustar liggesusers"loadmatrix" <- structure(function(filename){ if(is.character(filename)) {file<-file(description=filename,open="r") }else file<-filename nn<-c("%") while(substr(nn[1],1,1)=="%") { nn<-read.table(file=file,nrows=1) print(paste(nn,collapse=" "))} 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/mean.max.col.R0000644000176200001440000000007613370034046015672 0ustar liggesusers"mean.max.col" <- function(x,...)mean(apply(x,2,max,...)) blockmodeling/R/two2one.R0000644000176200001440000000056713370034046015014 0ustar liggesusers"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/rand.R0000644000176200001440000000022713370034046014334 0ustar liggesusers"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/rand2.R0000644000176200001440000000025213370034046014414 0ustar liggesusers"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/mean.max.row.R0000644000176200001440000000007613370034046015724 0ustar liggesusers"mean.max.row" <- function(x,...)mean(apply(x,1,max,...)) blockmodeling/R/usepos.R0000644000176200001440000000004713370034046014726 0ustar liggesusers"usepos" <- function(x)ifelse(x>0,x,0)blockmodeling/R/loadvector2.R0000644000176200001440000000077013370034046015637 0ustar liggesusers"loadvector2" <- structure(function(filename){ if(is.character(filename)) {file<-file(description=filename,open="r") }else file<-filename nn <-read.table(file=file,nrows=1,stringsAsFactors=FALSE) while(tolower(nn[1])!="*vertices") nn <-read.table(file=file,nrows=1,stringsAsFactors=FALSE) vv<-read.table(file=file,nrows=nn[[2]]) if (dim(vv)[2]==1) vv<-vv[[1]] if(is.character(filename)) close(file) vv } , comment = "Load vector(s) from file that was produced by Pajek") blockmodeling/R/REGE.ow.R0000644000176200001440000000256413370034046014564 0ustar liggesusers"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 diag(Eall[,,1])<-1 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/parOKgroups.R0000644000176200001440000000031013370034046015655 0ustar liggesusers"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/reorderImage.R0000644000176200001440000000035413370034046016016 0ustar liggesusersreorderImage<-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.R0000644000176200001440000000152113370034046015555 0ustar liggesusers"plot.mat.nm" <- plotMatNm <- 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/savenetwork.R0000644000176200001440000000536213370034046015765 0ustar liggesusers"savenetwork" <- structure(function(n,filename,twomode="default",symetric=NULL){ if(length(grep(pattern="w32",x=version["os"]))){ eol<-"\n" }else{eol<-"\r\n"} rowNames<-rownames(n) colNames<-colnames(n) if(requireNamespace("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); cat(paste(seq(1,length=dim(n)[1]),' "',rowNames,'"',eol,sep=""), 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 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); 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/fun.by.blocks.default.R0000644000176200001440000000336413375337171017527 0ustar liggesusers"fun.by.blocks.default" <- function(x = M, M = x, clu, ignore.diag = "default", sortNames = TRUE, FUN = "mean", ...) { M<-as.array(M) dM<-dim(M) nn<-ifelse(length(dM)==2,1,dM[1]) if(is.list(clu)){ nmode<-length(clu) if(nmode>2){ clu<-unlist(clu) clu<-list(clu,clu) } } else { clu<-list(clu,clu) nmode<-1 } clu<-lapply(clu,factor) if(ignore.diag =="default"){ if(length(dM)==3){ ignore.diag <-all(apply(M,1,function(x)identical(ss(diag(x)),0)))&(nmode==1) } else ignore.diag <-identical(ss(diag(M)),0)&(nmode==1) } if(sortNames) { k <- lapply(clu,function(x)sort(unique(x))) }else { k <- lapply(clu,function(x)unique(x)) } IM.V <- array(NA, dim=c(nn,length(k[[1]]),length(k[[2]]))) dimnames(IM.V)<-c(list(1:nn),k) for(iNet in 1:nn){ if(length(dM)==3) iM <- M[iNet,,] else iM<-M for (i in k[[1]]) { for (j in k[[2]]) { B<-iM[clu[[1]] == i, clu[[2]] == j, drop = FALSE] if (nmode==1 && i == j && ignore.diag) diag(B) <- NA #removed "dim(B)[1] > 1 &&" from condition above - produces NA's in IM in the diagonal blocks in case of dimension 1x1 lpar<-list(x = B,...) FUNchar<-FUN if(!is.character(FUNchar)) FUNchar<-deparse(substitute(FUN)) if(FUNchar %in% c("mean","sum","min","max")){ if(!("na.rm"%in%names(lpar))) lpar<-c(lpar, list(na.rm=TRUE)) } IM.V[iNet,i, j] <- do.call(FUN, lpar)#, na.rm = TRUE } } } if(nn==1) return(IM.V[1,,]) else return(IM.V) } blockmodeling/R/loadnetwork2.R0000644000176200001440000001026013370034046016021 0ustar liggesusers"loadnetwork2" <- function(filename,useSparseMatrix=NULL,minN=50,safe=TRUE,closeFile=TRUE){ if(is.character(filename)){ file<-file(description=filename,open="r") } else file<-filename while(TRUE){ line<-scan(file = file, nlines =1,what="char",quiet =TRUE, blank.lines.skip=FALSE) if(substr(line[1],start=1,stop=1)=="%") {print(paste(line,collapse=" "));next} if(line[1]=="") next n<-line break } if(length(n)==2){ n<-as.numeric(n[2]) if(safe){ vnames<-rep(as.character(NA),n) while(TRUE){ line<-scan(file = file, nlines =1,what="char",quiet =TRUE, blank.lines.skip=FALSE) if(length(line)==0||sum(grep(pattern="^ *$",x=as.character(line))==1)) break if(line[1]=="") break if(substr(line[1],start=1,stop=1)=="%") {print(paste(line,collapse=" "));next} if(substr(line[1],start=1,stop=1)=="*"){ type=line[1] break } vnames[as.integer(line[1])]<-line[2] } }else{ vnames<-read.table(file=file,nrows=n,as.is =TRUE)[,2] type="" } if(all(is.na(vnames))){ vnames<-NULL } else vnames[is.na(vnames)]<-"" if(is.null(useSparseMatrix)){ useSparseMatrix<- n>=50 } if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::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) } if(type=="*Matrix"){ tmp<-read.table(file=file,nrows=n) tmp<-as.matrix(tmp) M[1:n,1:n]<-M } else while(TRUE){ line<-scan(file = file, nlines =1,what="char",quiet =TRUE, blank.lines.skip=FALSE) if(length(line)==0||sum(grep(pattern="^ *$",x=as.character(line))==1)) break if(substr(line[1],start=1,stop=1)=="%") {print(paste(line,collapse=" "));next} if(substr(line[1],start=1,stop=1)=="*"){ type=line[1] next }else line<-as.double(line) if(tolower(type)=="*arcs"){ M[line[1],line[2]]<-line[3] }else if(tolower(type)=="*edges") { M[line[1],line[2]]<-line[3] M[line[2],line[1]]<-line[3] } } dimnames(M)<-list(vnames,vnames) } else if(length(n)==3){ n12<-as.numeric(n[2]) n1<-as.numeric(n[3]) n2<-n12-n1 if(safe){ vnames<-rep(as.character(NA),n12) while(TRUE){ line<-scan(file = file, nlines =1,what="char",quiet =TRUE, blank.lines.skip=FALSE) if(length(line)==0||sum(grep(pattern="^ *$",x=as.character(line))==1)) break if(substr(line[1],start=1,stop=1)=="%") {print(paste(line,collapse=" "));next} if(substr(line[1],start=1,stop=1)=="*"){ type=line[1] break } vnames[as.integer(line[1])]<-line[2] } }else{ vnames<-read.table(file=file,nrows=n12,as.is =TRUE)[,2] type="" } if(all(is.na(vnames))){ vnames<-NULL } else vnames[is.na(vnames)]<-"" if(is.null(useSparseMatrix)){ useSparseMatrix<- n12>50 } if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::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) } if(type=="*Matrix"){ tmp<-read.table(file=file,nrows=n1) tmp<-as.matrix(tmp) M[1:n1,(n1+1):n12]<-tmp } else while(TRUE){ line<-scan(file = file, nlines =1,what="char",quiet =TRUE, blank.lines.skip=FALSE) if(length(line)==0||sum(grep(pattern="^ *$",x=as.character(line))==1)) break if(substr(line[1],start=1,stop=1)=="%") {print(paste(line,collapse=" "));next} 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] } else stop("Error in line: ", line) if(closeFile) close(file) M[is.na(M)]<-1 return(M) } blockmodeling/R/plot.opt.more.par.R0000644000176200001440000000104213370034046016705 0ustar liggesusers"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=clu(x,which=which),IM=x$best[[which]]$IM,main=main,...) } blockmodeling/R/plot.opt.more.par.mode.R0000644000176200001440000000105013370034046017627 0ustar liggesusers"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/genMatrixMult.r0000644000176200001440000000056113370034046016251 0ustar liggesusersgenMatrixMult<-function(A,B,FUNelement="*", FUNsummary=sum){ if(dim(A)[2]!=dim(B)[1]) stop("incompatible dimmensions") n1<-dim(A)[1] n2<-dim(B)[2] X<-matrix(NA,nrow=n1,ncol=n2) dimnames(X)=list(dimnames(A)[[1]],dimnames(B)[[2]]) for(i1 in 1:n1){ for(i2 in 1:n2){ X[i1,i2]<-FUNsummary(do.call(FUNelement,list(A[i1,],B[,i2]))) } } return(X) } blockmodeling/R/genRandomParGroups.R0000644000176200001440000000555313370034046017174 0ustar liggesusers"genRandomParGroups" <- function( k,#number of clusters n=NULL,#the number of units seed=NULL,#the seed for random generation of partitions mingr=1, #minimal alowed group size maxgr=Inf, #maximal alowed group size addParam = list( k = NULL, #number of clusters by groups groups = NULL, #partition of units into groups. The generated partitions are such that units from different groups can not be in the same cluster. Groups are handled similarly as modes in original fucintion genPajekPar = TRUE, #Should the partitions be generated as in Pajek (the other options is completly random) probGenMech = NULL) #Here the probabilities for the 4 different mechanizems for specifying the partitions are set. It should be a numeric vector of length 4. If not set this is determined based on the previous parameter. ){ if(is.null(addParam$probGenMech)){ if(is.null(addParam$genPajekPar)||addParam$genPajekPar) probGenMech <- c(1/3,1/3,1/3,0) else probGenMech <- c(0,0,0,1) } else probGenMech<-addParam$probGenMech if(k!=sum(addParam$k)) warning("The number of clusters indicated by k and addParam$k is different!!!\n") k<-addParam$k if(!is.null(seed))set.seed(seed) nmode <- length(k) groups<-as.integer(factor(addParam$groups)) n<-table(groups) ver<-sample(1:4,size=1,prob=probGenMech) if(nmode==1){ find.new.par<-TRUE while(find.new.par){ if(ver!=4){ temppar<-integer(n) if(ver==1){ temppar<-1:n%%k+1 } if(ver==2){ temppar[1:k]<-1:k temppar[(k+1):n]<-k } if(ver==3){ temppar[1:k]<-1:k temppar[(k+1):n]<-1+trunc(k*runif(n-k)) } for(ii in n:2){ jj<-trunc(ii*runif(1)) temppar[c(ii,jj)]<-temppar[c(jj,ii)] } }else temppar<-sample(1:k,n,replace=TRUE) temptab<-table(temppar) if(length(temptab)==k&min(temptab)>=mingr&max(temptab)<=maxgr)find.new.par<-FALSE } }else{ temppar<-integer(sum(n)) for(imode in 1:nmode){ find.new.par<-TRUE while(find.new.par){ if(ver!=4){ itemppar<-integer(n[imode]) if(ver==1){ itemppar<-1:n[imode]%%k[imode]+1 } if(ver==2){ itemppar[1:k[imode]]<-1:k[imode] itemppar[(k[imode]+1):n[imode]]<-k[imode] } if(ver==3){ itemppar[1:k[imode]]<-1:k[imode] itemppar[(k[imode]+1):n[imode]]<-1+trunc(k[imode]*runif(n[imode]-k[imode])) } for(ii in n[imode]:2){ jj<-trunc(ii*runif(1)) itemppar[c(ii,jj)]<-itemppar[c(jj,ii)] } }else itemppar<-sample(1:k[imode],n[imode],replace=TRUE) temptab<-table(itemppar) if(length(temptab)==k[imode]&min(temptab)>=mingr&max(temptab)<=maxgr) find.new.par<-FALSE } itemppar<-itemppar + max(temppar) temppar[groups==imode]<-itemppar } } return(temppar) } blockmodeling/R/loadpajek.R0000644000176200001440000000501113370034046015336 0ustar liggesusersloadpajek<-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, blank.lines.skip=FALSE) if(length(line)==0) { break } if (substr(line[1],start=1,stop=1)=="%") { print(paste(line,collapse=" ")) next } if(line[1]=="") next if(sum(grep(pattern="^ *$",x=as.character(line))==1)) next if(tolower(tolower(line[1]))=="*matrix" || tolower(line[1])=="*network"){ objName<-paste(line[-1],collapse=" ") if(tolower(line[1])=="*matrix"){ readObj<-loadmatrix(file) }else readObj<-loadnetwork2(file, closeFile=FALSE) 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(tolower(line[1])=="*vector" || tolower(line[1])=="*permutation" || tolower(line[1])=="*partition"){ objName<-paste(line[-1],collapse=" ") readObj<-loadvector2(file) if(tolower(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(tolower(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(tolower(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/find.cut.R0000644000176200001440000000222113370034046015116 0ustar liggesusers"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]<-critFunC(M=M,clu=clu,blocks=c("nul",alt.blocks),preSpecM = cuts[i],approaches="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/one2two.R0000644000176200001440000000061113370034046015002 0ustar liggesusers"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/plot.opt.par.mode.R0000644000176200001440000000104313370034046016670 0ustar liggesusers"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/crand.R0000644000176200001440000000041713370034046014500 0ustar liggesusers"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/find.m.R0000644000176200001440000000644213370034046014570 0ustar liggesusers"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/onAttach.R0000644000176200001440000000027713370034046015156 0ustar liggesusers.onAttach<-function(libname, pkgname){ requireNamespace("utils") cit<-citation(pkgname) txt<-paste(c(format(cit,"citation")),collapse="\n\n") packageStartupMessage(txt) }blockmodeling/R/meanpos.R0000644000176200001440000000005313370034046015047 0ustar liggesusers"meanpos" <- function(v){mean(v[v>0])} blockmodeling/R/formatA.R0000644000176200001440000000014613370034046015001 0ustar liggesusers"formatA" <- function(x,digits=2, FUN=round,...){ noquote(format(FUN(x, digits=digits),...)) } blockmodeling/R/crand2.R0000644000176200001440000000046113370034046014561 0ustar liggesusers"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/plot.check.these.par.R0000644000176200001440000000105213370034046017327 0ustar liggesusers"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/fun.by.blocks.opt.more.par.R0000644000176200001440000000060713370034046020412 0ustar liggesusers"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/plot.mat.R0000644000176200001440000005400613620064705015155 0ustar liggesusers"plot.mat" <- plotMat <- 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=FALSE, #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.01, #y coordiante of the x axis values y.axis.val.pos = -0.01, #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=NULL, #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, nul=100), blackdens=70, plotLines = FALSE, #Should the lines in the matrix be printed (best set to FALSE for larger networks) frameMatrix=TRUE, #Should the matrix be framed (if plotLines is FALSE) x0ParLine=-0.1, #x coordinates for lines between row clusters x1ParLine=1, #x coordinates for lines between row clusters y0ParLine=0, #y coordinates for lines between col clusters y1ParLine=1.1, #y coordinates for lines between col clusters colByUnits=NULL, #a vector (of 0s and 1s) indicating whether ties of a unit should be marked with a diferent (nonblack) color - only used for binary networks colByRow=NULL, #a vector (of 0s and 1s) indicating whether outgoing ties of a unit should be marked with a different (nonblack) color - only used for binary networks colByCol=NULL, #a vector (of 0s and 1s) indicating whether incoming ties of a unit should be marked with a different (nonblack) color - only used for binary networks mulCol = 2, joinColOperator = "+", colTies=FALSE, maxValPlot=NULL, # maximal value used for determining the color of cells in the plot. This value and all higher (in absolute terms) will produce a pure black/red color printMultipliedMessage = TRUE, # shold mutiplication message be printed when values were the printed tie values are multiplied replaceNAdiagWith0=TRUE, #Should the diagonal with only NAs be replace by 0s? colLabels=FALSE, # Should the labels of units be colored. If FALSE, these are not collored, if TRUE, they are colored with colors of clusters as defined by palette. This can be aslo a vector of colors (or integers) for one-mode networks or a list of two such vectors for two-mode networks. ... #aditional arguments to plot.default ){ old.mar<-par("mar") if(length(dim(IM))>length(dim(IM))&use.IM){ if(is.null(wIM))wIM<-wnet if(is.null(wIM)) wIM<-1 if(length(dim(IM))==3) { IM<-IM[wIM,,] } else{ warning("IM will not be used for plotting. Cannot be sure how to extract the appropirate part!") use.IM<-FALSE } } tempClu<-clu if(length(dim(M))>2){ if(!is.null(wnet)){ relDim<-which.min(dim(M)) if(relDim==1){ M<-M[wnet,,] }else if(relDim==3){ M<-M[,,wnet] }else stop("More than 2 dimensions where relation dimension can not be determined") }else{ plot.array(M = M, clu=tempClu, #partition ylab=ylab, xlab=xlab, main.title=main,main.title.line=-2, print.val=print.val, #should the values be printed inside the cells print.0=print.0, #should the values equal to 0 be printed inside the cells, only used if 'print.val == TRUE' plot.legend=plot.legend, #should the legend for the colors be ploted print.legend.val=print.legend.val, #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=print.digits.legend, #the number of digits that should appear in the legend print.digits.cells=print.digits.cells, #the number of digits that should appear in the cells (of the matrix and/or legend) print.cells.mf=print.cells.mf, #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=outer.title, #should the title be printed on the 'inner' or 'outer' plot, default is 'inner' if legend is ploted and 'outer' otherwise title.line= title.line, #the line (from the top) where the title should be printed mar= 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 default is 'c(5, 4, 4, 2) + 0.1'. cex.val=cex.val, #size of the values printed val.y.coor.cor = val.y.coor.cor, #correction for centering the values in the sqares in y direction val.x.coor.cor = val.x.coor.cor, #correction for centering the values in the sqares in x direction cex.legend=cex.legend, #size of the text in the legend, legend.title=legend.title, #the title of the legend cex.axes=cex.axes, #size of the characters in axes, 'default' makes the cex so small that all categories can be printed print.axes.val=print.axes.val, #should the axes values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL' print.x.axis.val=print.x.axis.val, #should the x axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL' print.y.axis.val=print.y.axis.val, #should the y axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL' x.axis.val.pos = x.axis.val.pos, #y coordiante of the x axis values y.axis.val.pos = y.axis.val.pos, #x coordiante of the y axis values cex.main=cex.main, cex.lab=cex.lab, yaxis.line=yaxis.line, #the position of the y axis (the argument 'line') xaxis.line=xaxis.line, #the position of the x axis (the argument 'line') legend.left=legend.left,#how much left should the legend be from the matrix legend.up=legend.up, #how much left should the legend be from the matrix legend.size=legend.size, #relative legend size legend.text.hor.pos=legend.text.hor.pos, #horizontal position of the legend text (bottom) - 0 = bottom, 0.5 = middle,... par.line.width = par.line.width , #the width of the line that seperates the partitions par.line.col = par.line.col, #the color of the line that seperates the partitions IM.dens= IM.dens, IM= IM, #Image used for ploting (shaded lines) wIM=wIM, #which IM (if more) should be used for ploting (defualt = wnet) - used if IM is an array use.IM=use.IM, #should IM be used for ploting? dens.leg=dens.leg, blackdens=blackdens, plotLines = plotLines,... ) return(invisible(NULL)) } } dm<-dim(M) if(!inherits(M, c("matrix","mat"))){ pack<-attr(class(M),"package") if(!(is.null(pack))&&pack=="Matrix"){ if(requireNamespace("Matrix")){ M<-as.matrix(M) } else stop("The supplied object needs Matrix packege, but the package is not available (install it!!!).") } else { warning("Attempting to convert object of class ",class(M)," to class 'matrix'. Keep fingers crossed.") M<-as.matrix(M) } } if(replaceNAdiagWith0 & all(is.na(diag(M)))) diag(M)<-0 if(is.null(main)){ objName<-deparse(substitute(M)) if(objName[1]=="x"){ objName<-deparse(substitute(x)) } if(length(objName)>1) objName="" main <- paste("Matrix",objName) if(nchar(main)>50) main<-substr(main,1,50) } #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)){ clu<-lapply(clu,function(x)as.integer(as.factor(x))) tmNclu<-sapply(clu,max) for(iMode in 2:length(tmNclu)){ clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) } unlistClu<-unlist(clu) if( all(length(unlistClu)==dm)) clu<-unlistClu } 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]])){ tclu.r<-table(clu[[1]]) or.r<-order(clu[[1]]) lines.row<- 1-cumsum(tclu.r)[-length(tclu.r)]*1/dm[1] } else{ or.r<-1:dim(M)[1] lines.row<-NULL } if(!is.null(clu[[2]])){ tclu.c<-table(clu[[2]]) or.c<-order(clu[[2]]) lines.col<-cumsum(tclu.c)[-length(tclu.c)]*1/dm[2] } else{ or.c<-1:dim(M)[2] lines.col<-NULL } } 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(length(cex.axes)==1) cex.axes<-c(cex.axes,cex.axes) if(cex.axes[1]=="default"){ #defining the size of text on the axes cex.y.axis<-min(15/dm[1],1) }else{ cex.y.axis<-cex.axes[1] } if(cex.axes[2]=="default"){ #defining the size of text on the axes cex.x.axis<-min(15/dm[2],1) }else{ cex.x.axis<-cex.axes[2] } #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] if(all(M %in% c(0,1))){ # browser() mulCol<-mulCol if(is.null(colByRow)&is.null(colByCol)) { colByRow<-colByCol<-colByUnits } else { if(is.null(colByRow)){ colByRow<-rep(0, length(colByCol)) mulCol<-1 } if(is.null(colByCol)){ colByCol<-rep(0, length(colByRow)) } colByUnits<-TRUE } col<-M if(all(col %in% c(0,1))& (!is.null(colByUnits))){ newCol<-outer(colByRow,colByCol*mulCol,FUN=joinColOperator) if(!is.null(clu)) newCol<-newCol[or.r,or.c] if(colTies){ col[M>0]<-col[M>0]+newCol[M>0] }else{ newCol[newCol>0]<-newCol[newCol>0]+1 col[M==0]<-col[M==0]+newCol[M==0] } } } else { aM<-abs(M) if(!is.null(maxValPlot)){ aM[aM>maxValPlot]<-maxValPlot } max.aM<-max(aM) aMnorm<-as.vector(aM)/max.aM if(max.aM!=0){ col<-grey(1-aMnorm) #definin the color of rectangules }else col<-matrix(grey(1),nrow=dm[1],ncol=dm[2]) col[M<0]<-paste("#FF",substr(col[M<0],start=4,stop=7),sep="") } asp<-dm[1]/dm[2] #making sure that the cells are squares par(mar=mar, xpd=NA) #ploting plot.default(c(0,1),c(0,1),type="n",axes=FALSE,ann=FALSE,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(frameMatrix) rect(xleft=0, ybottom=0, xright=1, ytop=1, cex.lab=cex.lab,border="black") if(!is.null(clu)){ #ploting the lines between clusters if(!is.null(lines.row)) segments(x0=x0ParLine,x1=x1ParLine,y0=lines.row,y1=lines.row,col=par.line.col,lwd=par.line.width) if(!is.null(lines.col)) segments(y0=y0ParLine,y1=y1ParLine,x0=lines.col,x1=lines.col,col=par.line.col,lwd=par.line.width ) } colYlabels <- colXlabels <- 1 if((length(colLabels)==1)&&is.logical(colLabels)){ if(colLabels){ if(is.null(clu)){ warning("clu not used!") } else { colYlabels <- clu[[1]] colXlabels <- clu[[2]] } } } else{ if(!is.list(colLabels))colLabels<-list(colLabels,colLabels) if(length(colLabels[[1]])==dm[1]){ colYlabels<-colLabels[[1]] } else { warning("colLabels for first dimmension of wrong length, no colors will be used!") } if(length(colLabels[[2]])==dm[2]){ colXlabels<-colLabels[[2]] } else { warning("colLabels for second dimmension of wrong length, no colors will be used!") } } if(!is.null(clu)){ if(length(colXlabels)>1) colXlabels<-colXlabels[or.c] if(length(colYlabels)>1) colYlabels<-colYlabels[or.r] } 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, col=colYlabels) 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, , col=colXlabels) 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)) aMnorm<-abs(norm.val) col.text<-1-round(aMnorm) 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) } "plot.array" <- plotArray <- 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 IM=NULL, #the image to be used for plotting ..., #aditional arguments to plot.mat main.title=NULL,main.title.line=-2,mfrow=NULL ){ if(is.null(main.title)){ objName<-deparse(substitute(M)) if(objName=="x")objName<-deparse(substitute(x)) main.title <- paste("Matrix",objName) if(nchar(main.title)>50) main.title<-substr(main.title,1,50) } dM<-dim(M) relDim<-which.min(dM) nDim<-dM[relDim] if(is.null(mfrow)|(prod(mfrow)0) { mins<-Eall[k,,it]*pmin(M[i,k,ir],M[j,,ir]) num<-num+max(mins) den<-den+min(pmax(M[i,k,ir],M[j,which(mins==max(mins)),ir])) #cat("M[i,k]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n") } if(M[k,i,ir]>0) { mins<-Eall[k,,it]*pmin(M[k,i,ir],M[,j,ir]) num<-num+max(mins) den<-den+min(pmax(M[k,i,ir],M[which(mins==max(mins)),j,ir])) #cat("M[k,i]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n") } if(M[j,k,ir]>0) { mins<-Eall[k,,it]*pmin(M[j,k,ir],M[i,,ir]) num<-num+max(mins) den<-den+min(pmax(M[j,k,ir],M[i,which(mins==max(mins)),ir])) #cat("M[j,k]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n") } if(M[k,j,ir]>0) { mins<-Eall[k,,it]*pmin(M[k,j,ir],M[,i,ir]) num<-num+max(mins) den<-den+min(pmax(M[k,j,ir],M[which(mins==max(mins)),i,ir])) #cat("M[k,j]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n") } } } if(den!=0) { Eall[j,i,it+1]<-Eall[i,j,it+1]<-num/den } else Eall[j,i,it+1]<-Eall[i,j,it+1]<-1 diag(Eall[,,it+1])<-1 } } if(normE){ diag(Eall[,,it+1])<-0 Eall[,,it+1]<-Eall[,,it+1]/sqrt(outer(apply(Eall[,,it+1],1,sum), apply(Eall[,,it+1],2,sum))) diag(Eall[,,it+1])<-max(Eall[,,it+1]) } if(until.change & all(Eall[,,it]==Eall[,,it+1])){ Eall<-Eall[,,1:(it+1)] break } } itnames<-0:(it) itnames[1]<-"initial" itnames[it+1]<-"final" dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],itnames) return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter,use.diag=use.diag)) } blockmodeling/R/loadnetwork4.R0000644000176200001440000000701013370034046016022 0ustar liggesusers"loadnetwork4" <- function(filename,useSparseMatrix=NULL,minN=50,fill=FALSE){ sc<-scan(filename,what="raw",sep="\n") sc<-gsub(pattern="\\",replacement="/",x=sc,fixed=TRUE) first<-sapply(sc,substr,start=1,stop=1) sc<-sc[first!="%"] first<-first[first!="%"] stars<-which(first=="*") stars<-c(stars,"*end"=length(sc)+1) n<-as.numeric(strsplit(sc[1]," +")[[1]][-1]) if(is.null(useSparseMatrix)){ useSparseMatrix<- n[1]>=minN } if(length(n)==1){ if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::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) } vnames<-rep(as.character(""),n) for(i in seq_along(stars)){ #i<-1 type<-strsplit(x=names(stars)[i],split=" +")[[1]][1] if(tolower(type)=="*vertices"){ #vnames<-rep(as.character(NA),n) verNames<-sc[(stars[i]+1):(stars[i+1]-1)] verNames<-paste(verNames,collapse="\n") verNames<-read.table(text=verNames,as.is=TRUE,fill=fill) vnames[verNames[,1]]<-verNames[,2] } else if(tolower(type)%in%c("*arcs","*edges")){ ties<-sc[(stars[i]+1):(stars[i+1]-1)] ties<-paste(ties,collapse="\n") ties<-read.table(text=ties) 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(tolower(type)=="*arcs"){ M[ties[,1:2]]<-ties[,3] } else if(tolower(type)=="*edges"){ M[ties[,1:2]]<-ties[,3] M[ties[,2:1]]<-ties[,3] } } dimnames(M)<-list(vnames,vnames) } } else{ n12<-n[1] n1<-n[2] n2<-n12-n1 if(is.null(useSparseMatrix)){ useSparseMatrix<- n12>50 } if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::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) } vnames<-rep(as.character(""),n12) for(i in seq_along(stars)){ #i<-1 type<-strsplit(x=names(stars)[i],split=" +")[[1]][1] if(tolower(type)=="*vertices"){ #vnames<-rep(as.character(NA),n12) verNames<-sc[(stars[i]+1):(stars[i+1]-1)] verNames<-paste(verNames,collapse="\n") verNames<-read.table(text=verNames,as.is=TRUE,fill=fill) vnames[verNames[,1]]<-verNames[,2] } else if(tolower(type)%in%c("*arcs","*edges")){ ties<-sc[(stars[i]+1):(stars[i+1]-1)] ties<-paste(ties,collapse="\n") ties<-read.table(text=ties) 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(tolower(type)=="*arcs"){ M[ties[,1:2]]<-ties[,3] } else if(tolower(type)=="*edges"){ 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/ss.R0000644000176200001440000000006513370034046014035 0ustar liggesusers"ss" <- function(x){sum(x^2)-sum(x)^2/length(x)} blockmodeling/R/loadnetwork3.R0000644000176200001440000000707613370034046016035 0ustar liggesusers"loadnetwork3" <- function(filename,useSparseMatrix=NULL,minN=50){ trim.trailing <- function (x) sub("\\s+$", "", x) 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] stars<-trim.trailing(stars) if(ind.stars[1]!=1){ print(paste(rLines[1:(ind.stars[1]-1)],collapse="\n")) } rm(rLines) n<-read.table(file=filename,skip=ind.stars[1]-1, nrows=1) print(paste(n,collapse=" ")) if(length(n)==2){ n<-as.numeric(n[2]) vnames<-rep(as.character(NA),n) vnamesTab<-read.table(file=filename,skip=1,nrows=ind.stars[2]-ind.stars[1],as.is =TRUE) vnames[vnamesTab[,1]]<-vnamesTab[,2] if(all(is.na(vnames))){ vnames<-NULL } else vnames[is.na(vnames)]<-"" if(is.null(useSparseMatrix)){ useSparseMatrix<- n>=50 } if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::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(requireNamespace("Matrix")){ M<-Matrix::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(tolower(stars[i])=="*arcs"){ M[ties[,1:2]]<-ties[,3] } else if(tolower(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(requireNamespace("Matrix")){ M<-Matrix::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/sumpos.R0000644000176200001440000000005113370034046014731 0ustar liggesusers"sumpos" <- function(v){sum(v[v>0])} blockmodeling/R/clu.R0000644000176200001440000000026713370034046014177 0ustar liggesusers"clu" <- function(res,which=1,...){ if("clu" %in% names(res)){ res$clu }else res$best[[which]]$clu } "partitions" <- function(res)lapply(res$best,function(x)x$clu) blockmodeling/R/savematrix.R0000644000176200001440000000360413370034046015575 0ustar liggesusers"savematrix" <- structure(function(n,filename,twomode=1){ if(length(grep(pattern="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); 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); 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/recode.R0000644000176200001440000000040113370034046014643 0ustar liggesusers"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/plot.crit.fun.R0000644000176200001440000000034213370034046016113 0ustar liggesusers"plot.crit.fun" <- function( x,#an "crit.fun" 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/IM.R0000644000176200001440000000055513375337171013733 0ustar liggesusers"IM" <- function(res,which=1, drop=TRUE, ...){ if(class(res)=="opt.more.par"){ IM<-res$best[[which]]$IM } else IM<-res$IM if(drop)IM<-drop(IM) return(IM) } "EM" <- function(res,which=1, drop=TRUE,...){ if(class(res)=="opt.more.par"){ EM<-res$best[[which]]$EM } else EM<-res$EM if(drop)EM<-drop(EM) return(EM) } blockmodeling/R/nkpar.R0000644000176200001440000000025013370034046014517 0ustar liggesusers"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/REGE.R0000644000176200001440000000302713370034046014133 0ustar liggesusers"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 diag(Eall[,,1])<-1 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/nkpartitions.R0000644000176200001440000000343713370034046016143 0ustar liggesusers"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/plot.opt.par.R0000644000176200001440000000211413370034046015745 0ustar liggesusers"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,...) } "plot.optPar" <- 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$clu,IM=x$IM,main=main,...) } blockmodeling/R/err.R0000644000176200001440000000015713370034046014202 0ustar liggesusers"err" <- function(res,...){ if(is.null(res[["best"]])){ min(res$err) }else res$best[[1]]$err } blockmodeling/R/gplot.R0000644000176200001440000000245213370034046014537 0ustar liggesusers"gplot1" <-function(M,diag=TRUE,displaylabels=TRUE,boxed.labels=FALSE,loop.cex=4,edge.lwd=1,edge.col="default",rel.thresh=0.05,...){ if(requireNamespace("sna", quietly = TRUE)){ M[M<(max(M)*rel.thresh)]<-0 if(edge.col[1]=="default") edge.col<-gray(1-M/max(M)) edge.col<-edge.col[edge.col!=gray(1)] sna::gplot(dat=M,diag=diag,displaylabels=displaylabels,boxed.labels=boxed.labels,loop.cex=loop.cex,edge.lwd=edge.lwd,edge.col=edge.col,...) } else stop("Package \"sna\" is needed for this function to work. Please install it.", call. = FALSE) } "gplot2" <- function(M,uselen=TRUE,usecurve=TRUE,edge.len=0.001,diag=TRUE,displaylabels=TRUE,boxed.labels=FALSE,loop.cex=4,arrowhead.cex=2.5,edge.lwd=1,edge.col="default",rel.thresh=0.05,...){ if(requireNamespace("sna", quietly = TRUE)){ M[M<(max(M)*rel.thresh)]<-0 if(edge.col[1]=="default") edge.col<-gray(1-M/max(M)) edge.col<-edge.col[edge.col!=gray(1)] sna::gplot(dat=M,uselen=uselen,usecurve=usecurve,edge.len=edge.len,diag=diag,displaylabels=displaylabels,boxed.labels=boxed.labels,loop.cex=loop.cex,arrowhead.cex=arrowhead.cex,edge.lwd=edge.lwd,edge.col=edge.col,...) } else stop("Package \"sna\" is needed for this function to work. Please install it.", call. = FALSE) } blockmodeling/R/ad.R0000644000176200001440000000005513370034046013773 0ustar liggesusers"ad" <- function(x)sum(abs(x-median(x))) blockmodeling/R/find.m2.R0000644000176200001440000000241713370034046014650 0ustar liggesusers"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]<-critFunC(M=M,clu=clu,blocks=c("nul",alt.blocks),preSpecM = ms[i],approaches="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/MD50000644000176200001440000001205513622060220013367 0ustar liggesusers54ef717ee43b4e433ca42f2baddd7d72 *CHANGES 3fe3029549e0be9783ba7ef75c66a4fa *DESCRIPTION 90cd85cc568c7066382b10f7acbdc8fc *NAMESPACE b8fc85871a22742477bdef7aff6b5ddf *R/Cinterfaces.R e61012cd30a8017bc95d26a0712e3849 *R/IM.R 2f51422a4e8c43a3461d230c20c5ceb7 *R/REGE.FC.R 80575603ee7dc48ee8f98c313de64389 *R/REGE.FC.ow.R c01d3f4f538983dcd67acba0b49a757c *R/REGE.R b0c4da4afb9b288803578cf18c6218e2 *R/REGE.ow.R c536b21cd42e47d8981a0ddbeb7f06e7 *R/REGE_for.R 0462637eb324ebc7a292036db143370a *R/ad.R d525da3b74398c04c6efa11b9fb93c60 *R/clu.R 601ded4f03167badfeac1a6939e2c538 *R/crand.R 4c97f844190be3a00bedd110fc66057c *R/crand2.R 39a6fbd417017a19624d34fbd125e5b8 *R/err.R 1317ad7c0f47a1eb54d3f2ef4b0245f0 *R/find.cut.R a977bb36598f9afc57c031d0dc71ea35 *R/find.m.R 42b0edaf68e3de9a5415903bc5b5a965 *R/find.m2.R 0d402201cbc4fee68d9d983360aafe3b *R/formatA.R 3381111228d5eda92f751d79fc81a829 *R/fun.by.blocks.R d30848515c8e7bf417ba6fc7a1a8fe9f *R/fun.by.blocks.default.R d32292104d5f90c9e972ce2f221bb8b9 *R/fun.by.blocks.opt.more.par.R f0e7145262ce7fcbb2ceef97d5b97348 *R/genMatrixMult.r 3edfa00c218f2ca76c1b356db10045b6 *R/genRandomPar.R 6471680113a196880a13826db1279a70 *R/genRandomParGroups.R 919fc6d9be1797e173886e2d843da4ff *R/gplot.R c6cde87c0909f5e0b6390218c83f0862 *R/ircNorm.R e2ed7bc03c847e2afb10b534e90ec2c2 *R/loadmatrix.R 67459f46ef34796bcd6d007dc04f1ca5 *R/loadnetwork.R 5ce9ba1ebe2b32157585da9a4fccde00 *R/loadnetwork2.R a2f48135c230e912ccfc288cac8c8b53 *R/loadnetwork3.R e7c807776e87e0897aa56426a7f0f928 *R/loadnetwork4.R 04cd626b8dda4e7e0410be30b6b7474a *R/loadpajek.R 55de856028d90f10a2b4f7a218ad08a4 *R/loadvector.R 56090fcae62ac3797e134255ee0a8853 *R/loadvector2.R ef2edf6e5ff44270119306a108458aac *R/mean.max.col.R c5c9b0bb964a09c8ca251539ce0b65bc *R/mean.max.row.R 0949efc03bfecf760f309b6cd674e915 *R/meanpos.R ea963ede050b8166e03e93df69282344 *R/nkpar.R 8472ede47bbb38971741f8d2b516059b *R/nkpartitions.R ef4be889b278782fac684d9bbf6859c3 *R/onAttach.R e7942ed973f79375fe4ef4cab477a948 *R/one2two.R 85b3127c3cea0e54ff37382b36e04226 *R/parOKgroups.R 1c0500ce587f38efb1b6c43d10f68a0f *R/plot.check.these.par.R d36226b8c596a378c21b59dea8a4a50e *R/plot.crit.fun.R 104bfb6a0f52c87b44f77d387b78332a *R/plot.mat.R 471bb2536526a127ed0b24450170fb90 *R/plot.mat.nm.R df66c0e2c69e65d060a954b513acb928 *R/plot.opt.more.par.R a5defacfcf43caecb72e8abc0efa44a4 *R/plot.opt.more.par.mode.R 328a1bcb858918e43cd9fbc850f5ee52 *R/plot.opt.par.R 35d41e265eb1fd901971a930e01348e8 *R/plot.opt.par.mode.R 9eb44fbc9c6d4fa5d37392a89ad6b6f8 *R/rand.R 00246d8c66e181e31c12714bf6bf5562 *R/rand2.R 573b1c8048f9a5801f2150579ac3d09b *R/recode.R b29784b7003e28f426a4c354f4aa3f39 *R/reorderImage.R 4f86bf5b5fc22bb215b1069126a466f6 *R/savematrix.R a65f20fafe2594be6b307def1a8dc744 *R/savenetwork.R 387d2a07484d7a29399b54034dc26fd7 *R/savevector.R 59217d6b6bcbc3de9d46feb3f8a1ee58 *R/sedist.R ad59aec2182068c236097be840bccc6e *R/ss.R 83f0894ed4e7b2baebc45ce5e4d3ea1a *R/sumpos.R 57d9f97d53a521b00cb96f961f8c40d6 *R/two2one.R cf56197339441d8de415e553dd25c348 *R/useneg.R 4c2cfa53f258d295e139a924e2208646 *R/usepos.R 3bd49e505e07c6c33dba595b6c8a930f *data/notesBorrowing.RData 497089ea38d28cfa4d0892b449db045e *inst/CITATION 36ee8790ef573cb24b84ff2a90796f00 *man/Pajek.Rd ef7cc437fa0c6a7162c777924c517ab2 *man/REGE.Rd 5f7d162f0b2d358921622fd44da31d98 *man/blockmodeling-package.Rd 8b883ee27289cd08002254d5e8221974 *man/clu.Rd 79f83858eb75de84bdd74ab46c2633ff *man/critFunC.Rd 61d67444eb932ab528c558eeaa682f5b *man/find.m.Rd eecd4ea7781f20965d8459bdb49046a8 *man/formatA.Rd 505eefeafbbf52b3c5aea0243762a19c *man/fun.by.blocks.Rd 59a128dd4a55c8974e005b46d291db1d *man/genMatrixMult.Rd aa2ca3c62c2a15a3b9ec4205938653b1 *man/genRandomPar.Rd 5bdd3829fd034f862c359f61f187a4ad *man/gplot1.Rd d1545b825ed319f47eb6cf959c5ab354 *man/ircNorm.Rd 1e92dcb64b5b3ae38c5136fee2ddefc9 *man/nkpartitions.Rd 0aeabe918396a370a3a0a4de34080ea6 *man/notesBorrowing.Rd d9c3bc2fbd90d0a0be4a34b46229f3e9 *man/optRandomParC.Rd b5cd768dee50708e1eed78efefcc18f6 *man/plot.mat.Rd b2f5ea8e91f3c0052fa5f9101ec51b51 *man/rand.Rd 2b2641f305dd0b2131b1337e537c93f0 *man/recode.Rd 732db23448b114c54b0d1e82c80ad0ed *man/reorderImage.Rd 883a11080c6546c5fc21385749750c53 *man/sedist.Rd 9ae0f360ec198686f2173fc37d5b8f0a *man/ss.Rd 8e00c5a8edd0e40beb39c83d29ce104a *man/two2one.Rd ee2ce2302b03b54e732b8dcf736a68ee *src/REGD_NE_R.f90 384f54d7e9e77d08e7492637b6bcc4c7 *src/REGD_OW_NE_R.f90 01cef6254bd782214a7f1f976ec9445f *src/REGD_OW_R.f90 9614f3d16a782f9e1b468ae16468c4e6 *src/REGD_R.f90 d37605404a7a59577ca9298148f9141e *src/REGE_NE_R.f90 0ff28cceabad99d356a76ca095eee0b7 *src/REGE_NM_DIAG_R.f90 3112931e39369317008cd145ae1a014e *src/REGE_NM_NE_R.f90 6cbe276a943ec813ccda3b5e17cf6f32 *src/REGE_NM_R.f90 c4144d6d8319d36ad517c9d4c7c09636 *src/REGE_OWNM_DIAG_R.f90 5397ff7d2a9e7b129901377a1e73d23a *src/REGE_OWNM_NE_R.f90 6c9dc2aa1418e2cc8b03dd8edfcce303 *src/REGE_OWNM_R.f90 86e8e8b740c8b2039de9219eac79796a *src/REGE_OW_NE_R.f90 a963f43557e2b9259be9f9622f8cbf5f *src/REGE_OW_R.f90 e1002e6867e1bd65194543d3676cd778 *src/REGE_R.f90 858ac8c45182e50383152b0747623910 *src/blockmodelingC.c 0baa1a4002a6f4dcc70d34b43c11724f *src/init.c blockmodeling/inst/0000755000176200001440000000000013621550333014041 5ustar liggesusersblockmodeling/inst/CITATION0000644000176200001440000000422313436175420015203 0ustar liggesuserscitHeader("To cite package '",meta$Package,"' in publications please use package citation and (at least) one of the articles:", sep="") # Grab the version and date from the DESCRIPTION file year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date) vers <- paste("R package version", meta$Version) aut<-eval(parse(text=meta$"Authors@R")) autText<-format(aut, include = c("family", "given"), braces = list(family = c("", ","))) citEntry(entry = "Article", title = "Generalized blockmodeling of valued networks", volume = "29", shorttitle = "Generalized blockmodeling of valued networks", # doi = "10.1016/j.socnet.2006.04.002", journal = "Social Networks", author = as.person("Aleš Žiberna"), year = "2007", number = "1", pages = "105--126", textVersion= "Žiberna, Aleš (2007). Generalized blockmodeling of valued networks. Social Networks 29(1), 105-126." ) citEntry(entry = "Article", title = "Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence", volume = "32", shorttitle = "Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence", doi = "10.1080/00222500701790207", journal = "Journal of Mathematical Sociology", author = as.person("Aleš Žiberna"), year = "2008", number = "1", pages = "57--84", textVersion = "Žiberna, Aleš (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology 32(1), 57–84." ) citEntry(entry = "Article", title = "Blockmodeling of Multilevel Networks", volume = "39", shorttitle = "Blockmodeling of Multilevel Networks", doi = "10.1016/j.socnet.2014.04.002", journal = "Social Networks", author = as.person("Aleš Žiberna"), year = "2014", pages ="46-61", textVersion = "Žiberna, Aleš (2014). Blockmodeling of multilevel networks. Social Networks 39, 46–61. https://doi.org/10.1016/j.socnet.2014.04.002." ) citEntry(entry="Manual", title = meta$Title, author= aut, year =year, note =vers, textVersion= paste(autText," (", year, "). ",meta$Title,", ", vers, ".", sep="") ) blockmodeling/CHANGES0000644000176200001440000000600313446640627014071 0ustar liggesusersName: blockmodeling Title: Generalized and Classical Blockmodeling of Valued Networks 2019 March 27, 2019 Version 0.3.5 Changed the default value of the paramter justChange in optPar(C) to TRUE. This speeds up the optimization. Previously it was set to FALSE so that tests could be made if the faster option gives the same/correct results. 2018 December 24, 2018 Added two arguments into optRandomParC (approaches and blocks). Also the description of these arguments was added into optRandomParC.Rd file November 29, 2018 A bug fixed in kmBlockORP that produced new cluster to be generated each time kmBlockORP was called in multicore mode. November 9, 2018 Version 0.3.4 Bug fixed in critFunC. November 7, 2018 Version 0.3.3 Corrected documentation on critFunC and optParC in the part on using argument "approaches". Also, the functions were updated so that "ss" and "ad" are accepted as values of the approaches argument (which was previously documented, but not supported). Function EM that extract the error matrix was added. November 5, 2018 Version 0.3.3 Some minor bug fixes, performance improvements and documentation improvements. September 3, 2018 Version 0.3.2 Edited grammar in help files. Several bug fixes in plotting functions. May 29, 2018 Version 0.3.1 Edited grammar in help files. Editing style (APA) of citaitons of blockmodeling package in publications. Added a reference for the method in the 'Description' field. April 25, 2018 Version 0.3.1 A bug fix which prevented the use of functions gplot1 and gplot2. April 10, 2018 Version 0.3.0 Final tweaks before submission to CRAN. March 28, 2018 Correcting some FORTRAN warnings. March 2, 2018 Version 0.2.4 Added help files for functions optRandomParC and critFunC. Updated help files (e.g. helpfile for function optParC was inserted (combined) in help file of function critFunC). Added new functions plotMat, plotArray and plotMatNm which are equivalent to the old functions plot.mat, plot.array and plot.mat.nm. The old functions will eventually be replaced with the new functions. 2017 December 8, 2017 Version: 0.2.3 Merged optParMultiC and optParC in to optParC. Added formating to returned clu from these functions. June 30, 2017 Seveal bug fixes. 2014 May 14, 2014 Version: 0.2.2 A bug in sedist fixed. 2013 Version: 0.2.2 Several improvements, added additional block types (rfn, cfn, cdo, rdo) and support for multilevel blockmodeling. 2012 November 15, 2012 Version: 0.2.2 Added posibility to differentially weight relations, block type and positions or based on specially designed weights. Added additional block types in C the blocks are now limited to: "nul", "com", "reg", "cre", "rre","dnc" Multicore support through package doParallel for function optRandomParC. February 9, 2012 Version: 0.2.1 Added optParMultiC - function for searching whole neighbourhood before moving to the next partition. Added valued blockmodeling in C (the blocks are still limited to nul, com and reg).