blockmodeling/0000755000176200001440000000000014471422772013075 5ustar liggesusersblockmodeling/NAMESPACE0000644000176200001440000000477114303451145014313 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(funByBlocks,default) S3method(funByBlocks,opt.more.par) S3method(funByBlocks,optMorePar) S3method(plot,check.these.par) S3method(plot,crit.fun) S3method(plot,critFun) S3method(plot,mat) S3method(plot,opt.more.par) S3method(plot,opt.more.par.mode) S3method(plot,opt.par) S3method(plot,opt.par.mode) S3method(plot,optMorePar) S3method(plot,optMoreParMode) S3method(plot,optPar) S3method(plot,optParMode) S3method(print,optMorePar) export(EM) export(IM) export(REGD.for) export(REGD.ne.for) export(REGD.ow.for) export(REGE) export(REGE.FC) export(REGE.FC.ow) export(REGE.for) export(REGE.ne.for) export(REGE.nm.diag.for) export(REGE.nm.for) export(REGE.nm.ne.for) export(REGE.ow) export(REGE.ow.for) export(REGE.ow.ne.for) export(REGE.ownm.diag.for) export(REGE.ownm.for) export(REGE.ownm.ne.for) export(RF) export(ad) export(canClu) export(canCluUniqe) export(clu) export(crand) export(crand2) export(critFunC) export(err) export(expandMat) export(find.cut) export(find.m) export(find.m2) export(formatA) export(fun.by.blocks) export(funByBlocks) export(genMatrixMult) export(genRandomPar) export(gplot1) export(gplot2) export(ircNorm) export(loadmatrix) export(loadnetwork) export(loadnetwork2) export(loadnetwork3) export(loadnetwork4) export(loadpajek) export(loadvector) export(loadvector2) export(nanRep) export(nkpar) export(nkpartitions) export(one2two) export(optParC) export(optRandomParC) export(orderClu) export(partitions) export(plot.mat) export(plotArray) export(plotMat) export(plotMatNm) export(printBlocks) export(rand) export(rand2) export(recode) export(relInv) export(relInv2) export(reorderImage) export(savematrix) export(savenetwork) export(savevector) export(sedist) export(splitClu) export(splitCluRes) export(ss) export(ssNa) export(two2one) export(unlistClu) export(unlistCluInt) import(Matrix) import(methods) import(parallel) importFrom(grDevices,gray) importFrom(graphics,mtext) importFrom(graphics,par) importFrom(graphics,plot.default) importFrom(graphics,rect) importFrom(graphics,segments) importFrom(graphics,text) importFrom(graphics,title) importFrom(stats,as.dist) importFrom(stats,cor) importFrom(stats,cov) importFrom(stats,median) importFrom(stats,na.omit) importFrom(stats,optimize) importFrom(stats,runif) importFrom(utils,citation) importFrom(utils,read.table) importFrom(utils,write.table) useDynLib(blockmodeling, .registration = TRUE) blockmodeling/data/0000755000176200001440000000000014362271051013775 5ustar liggesusersblockmodeling/data/notesBorrowing.RData0000644000176200001440000000041613677022067017745 0ustar liggesusers r0b```b`fcb`b2Y# '/I-v/*/K*dpI (Տ\Aw@.N+Ai(m&oׁ"a`샹@wV Rqf 큻h2hhS@U/,HASǁ&]8zObO54>* GI|R2d)^P yєp%Pu1Y0KMblockmodeling/data/baker.rda0000644000176200001440000000066513677022067015571 0ustar liggesusersBZh91AY&SY(l{B0mFLE=$yGѡ  (i40!@!JiO(dM@2ѐdE c(9e)rVBqDo6$Au@9l26LZ[6[ᱫl ʫ( 6oEԂƲ(,TGNdJ'&\1J[m\lYr|/ qÇEI -$ɐ8B&ImjcNJ0|\QEsGn#2:!ʃY9 DMDAD1$9pa$0 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) err(res) # The error is relatively small IM(res) # The image corresponds to the one used for generation of # The network plot(res) } \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 } \seealso{ \code{\link{optRandomParC}}, \code{\link{critFunC}}, \code{\link{optParC}}, \code{\link{IM}}, \code{\link{clu}}, \code{\link{err}}, \code{\link{plotMat}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{cluster} \keyword{graphs} \keyword{package} blockmodeling/man/nanRep.Rd0000644000176200001440000000104614026571742015361 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nanRep.R \encoding{UTF-8} \name{nanRep} \alias{nanRep} \title{Replaces NaN values by the speficied values (0 by default)} \usage{ nanRep(x, rep = 0) } \arguments{ \item{x}{A vector or similar where the NaNs are to be replaced.} \item{rep}{A value that should replace the NaNs (0 by default).} } \value{ x with NaNs replaced by rep. } \description{ Replaces NaN values by the speficied values (0 by default) } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{manip} blockmodeling/man/genRandomPar.Rd0000644000176200001440000000362514124334533016512 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/genRandomPar.R \name{genRandomPar} \alias{genRandomPar} \title{The function for generating random partitions} \usage{ genRandomPar( k, n, seed = NULL, mingr = 1, maxgr = Inf, addParam = list(genPajekPar = TRUE, probGenMech = NULL) ) } \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. } \description{ The function generates random partitions. The function is meant to be called by the function \code{\link{optRandomParC}.} } \references{ Batagelj, V., & Mrvar, A. (2006). Pajek 1.11. Retrieved from http://vlado.fmf.uni-lj.si/pub/networks/pajek/ } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{cluster} blockmodeling/man/unlistClu.Rd0000644000176200001440000000271114270233277016117 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unlistClu.R \encoding{UTF-8} \name{unlistClu} \alias{unlistClu} \title{Function for "unlisting" a partition.} \usage{ unlistClu(clu, renumber = FALSE) } \arguments{ \item{clu}{A list representing a partition of units from different sets. Each element should be a partition for one set.} \item{renumber}{If \code{TRUE} (default), are renumbered so that they are 1:"total number of clusters". If any cluster "ID" is present in more than one set of units (one partition, one element of the list), this is done even if \code{renumber = FALSE}.} } \value{ A vector representing a partition. It also has an attribute \code{n} with the number of units that were in each set. } \description{ Essentially, if the argument is a list (otherwise function just returns its argument), the function calls unlist on it. Before it, it however makes sure that names from different elements of the list to not repeat. The opposite of \code{\link{splitClu}}. The \code{n} argument of the \code{\link{splitClu}} is returned as an attribute. If \code{renumber=TRUE} (default), it is practically identical to unlistCluInt. } \examples{ n <- c(8,8) cluList <- c(rep(1:2, times = c(3, 5)), rep(5:6, times = c(3, 5))) unlistClu(clu = clu) unlistClu(clu = clu, renumber = FALSE) } \seealso{ \code{\link{clu}}, \code{\link{splitClu}}, \code{\link{unlistCluInt}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{manip} blockmodeling/man/two2one.Rd0000644000176200001440000000414313677022070015530 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/one2two.R, R/two2one.R \encoding{UTF-8} \name{one2two} \alias{one2two} \alias{two2one} \title{Two-mode network conversions} \usage{ one2two(M, clu = NULL) two2one(M, clu = NULL) } \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.} } \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. } \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) } \seealso{ \code{\link{optParC}}, \code{\link{optParC}}, \code{\link{optRandomParC}}, \code{\link{plot.mat}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{cluster} \keyword{graphs} blockmodeling/man/REGE.Rd0000644000176200001440000001356313677041356014673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/REGE.FC.R, R/REGE.FC.ow.R, R/REGE.R, % R/REGE.ow.R, R/REGE_for.R \encoding{UTF-8} \name{REGE.FC} \alias{REGE.FC} \alias{REGE.FC.ow} \alias{REGE} \alias{REGE.ow} \alias{REGE.for} \alias{REGD.for} \alias{REGE.ow.for} \alias{REGD.ow.for} \alias{REGE.ownm.for} \alias{REGE.ownm.diag.for} \alias{REGE.nm.for} \alias{REGE.nm.diag.for} \alias{REGE.ne.for} \alias{REGE.ow.ne.for} \alias{REGE.ownm.ne.for} \alias{REGE.nm.ne.for} \alias{REGD.ne.for} \alias{REGD.ow.ne.for} \title{REGE - Algorithms for compiting (dis)similarities in terms of regular equivalnece} \usage{ 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 ) REGE(M, E = 1, iter = 3, until.change = TRUE, use.diag = TRUE) REGE.ow(M, E = 1, iter = 3, until.change = TRUE, use.diag = TRUE) REGE.for(M, iter = 3, E = 1) REGD.for(M, iter = 3, E = 0) REGE.ow.for(M, iter = 3, E = 1) REGD.ow.for(M, iter = 3, E = 0) REGE.ownm.for(M, iter = 3, E = 1) REGE.ownm.diag.for(M, iter = 3, E = 1) REGE.nm.for(M, iter = 3, E = 1) REGE.nm.diag.for(M, iter = 3, E = 1) REGE.ne.for(M, iter = 3, E = 1) REGE.ow.ne.for(M, iter = 3, E = 1) REGE.ownm.ne.for(M, iter = 3, E = 1) REGE.nm.ne.for(M, iter = 3, E = 1) REGD.ne.for(M, iter = 3, E = 0) REGD.ow.ne.for(M, iter = 3, E = 0) } \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.} ... } \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. } \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 } \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}} } \keyword{cluster} \keyword{graphs} blockmodeling/man/formatA.Rd0000644000176200001440000000155513677022070015530 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formatA.R \encoding{UTF-8} \name{formatA} \alias{formatA} \title{A formating function for numbers} \usage{ formatA(x, digits = 2, FUN = round, ...) } \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. } \description{ Formats a vector or matrix of numbers so that all have equal length (digits). This is especially suitable for printing tables. } \examples{ A <- matrix(c(1, 1.02002, 0.2, 10.3), ncol = 2) formatA(A) } \seealso{ \code{\link{find.m}}, \code{\link{find.m2}}, \code{\link{find.cut}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{character} blockmodeling/man/recode.Rd0000644000176200001440000000111113677022070015364 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recode.R \encoding{UTF-8} \name{recode} \alias{recode} \title{Recode} \usage{ recode(x, oldcode = sort(unique(x)), newcode) } \arguments{ \item{x}{A vector.} \item{oldcode}{A vector of old codes.} \item{newcode}{A vector of new codes.} } \value{ A recoded vector. } \description{ Recodes values in a vector. } \examples{ x <- rep(1:3, times = 1:3) newx <- recode(x, oldcode = 1:3, newcode = c("a", "b", "c")) } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{manip} blockmodeling/man/critFunC.Rd0000644000176200001440000003625214270233277015661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/critFunC.R \encoding{UTF-8} \name{critFunC} \alias{critFunC} \alias{optParC} \title{Functions for Generalized blockmodeling for valued networks} \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, mulReg = TRUE, addGroupLlErr = TRUE ) 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", fixClusters = NULL, save.initial.param = TRUE, mulReg = TRUE, addGroupLlErr = TRUE ) } \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 block types. 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 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 symmetric.} \item{diag}{Should the special status of diagonal be acknowledged. A single number or a vector equal to the number of relation. The default value is set to \code{1}. Codes: \cr \code{0} - diagonal is treated in the same way as other values \cr \code{1} - diagonal is treated separately, or \cr \code{2} - diagonal values are ignored. \cr} \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 demand 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 homogeneity blockmodeling two variability criteria can be used: \code{"ss"} - sum of squares (set by default), \code{"ad"} - absolute deviations and \code{"bll"} - - (minus) binary log-likelihood.} \item{usePreSpecM}{Specifying weather a pre-specified value should be used when computing inconsistency.} \item{preSpecM}{Sufficient 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 across block types (see \code{blocks} above). It must be suplied in form of a named vector, 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{mulReg}{Should the errors that apply to rows/columns (and not to cells) should be multiplied by number of rows/columns. Defaults to TRUE.} \item{addGroupLlErr}{Used only when stochastic generalized blockmodeling is used. Should the total error included the part based on sizes of groups. Defaults to TRUE. Will return wrong results for two-mode networks if critFunC is called directly (should be fine if called via optParC function).} \item{nMode}{Number of nodes. If \code{NULL}, then determined from \code{clu}.} \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{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.} \item{fixClusters}{Clusters to be fixed. Used only if \code{exchageClusters = "all"}. A vector of integers that specify clusters to be fixed, where clusters are numbered from 1 to the total (in all modes or sets) number of clusters.} } \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.} } \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. } \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 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 set.seed(1) 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 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) # Optimizing one partition res <- optParC(M = net, clu = clu.rnd, approaches = "hom", homFun = "ss", blocks = "com") plot(res) # Hopefully we get the original partition } \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 } \seealso{ \code{\link{optRandomParC}}, \code{\link{IM}}, \code{\link{clu}}, \code{\link{err}}, \code{\link{plot.critFun}} } \author{ \enc{Aleš, Žiberna}{Ales Ziberna} } \keyword{cluster} \keyword{graphs} blockmodeling/man/genMatrixMult.Rd0000644000176200001440000000222413677022070016731 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/genMatrixMult.r \name{genMatrixMult} \alias{genMatrixMult} \title{Generalized matrix multiplication} \usage{ genMatrixMult(A, B, FUNelement = "*", FUNsummary = sum) } \arguments{ \item{A}{The first matrix.} \item{B}{The second matrix.} \item{FUNelement}{Element-wise operator.} \item{FUNsummary}{Summary function.} } \value{ A character vector or matrix. } \description{ Computes a generalized matrix multiplication, where sum and product functions (elemet-wise and summary functions) can be replaced by arbitrary functions. } \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) } \seealso{ \code{\link{matmult}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{algebra} \keyword{array} blockmodeling/man/clu.Rd0000644000176200001440000000576614076015230014724 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/clu.R \encoding{UTF-8} \name{clu} \alias{clu} \alias{partitions} \alias{err} \alias{IM} \alias{EM} \title{Function for extraction of some elements for objects, returend by functions for Generalized blockmodeling} \usage{ clu(res, which = 1, ...) partitions(res) err(res, ...) IM(res, which = 1, drop = TRUE, ...) EM(res, which = 1, drop = TRUE, ...) } \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{\dots}{Not used.} \item{drop}{If \code{TRUE} (default), dimensions that have only one level are dropped (\code{drop} function is applied to the final result).} } \value{ The desired element. } \description{ Functions for extraction of partition (\code{clu}), all best partitions (\code{partitions}), image or blockmodel (\code{IM})) and total error or inconsistency (\code{err}) for objects, returned by functions \code{\link{critFunC}} or \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. } \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 } \seealso{ \code{\link{critFunC}}, \code{\link{plot.mat}}, \code{\link{optRandomParC}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{manip} blockmodeling/man/Pajek.Rd0000644000176200001440000000766614216546425015207 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loadmatrix.R, R/loadnetwork.R, % R/loadnetwork2.R, R/loadnetwork3.R, R/loadnetwork4.R, R/loadpajek.R, % R/loadvector.R, R/loadvector2.R, R/savematrix.R, R/savenetwork.R, % R/savevector.R \name{loadmatrix} \alias{loadmatrix} \alias{Pajek} \alias{loadnetwork} \alias{loadnetwork2} \alias{loadnetwork3} \alias{loadnetwork4} \alias{savevector} \alias{savenetwork} \alias{savematrix} \alias{loadvector} \alias{loadvector2} \alias{loadpajek} \title{Functions for loading and writing Pajek files} \usage{ loadmatrix(filename) 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) loadpajek(filename) loadvector(filename) loadvector2(filename) savematrix(n, filename, twomode = 1) savenetwork(n, filename, twomode = "default", symetric = NULL) savevector(v, filename) } \arguments{ \item{filename}{The name of the file 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{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.} \item{fill}{If \code{TRUE}, then in case the rows have unequal length, blank fields are added.} \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.} } \value{ NULL, a matrix or a vector. } \description{ \code{loadmatrix} - Loads a Pajek ".mat" filename as a matrix. 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{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. \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{savematrix} - Saves a matrix into a Pajek ".mat" filename. \code{savenetwork} - Saves a matrix into a Pajek ".net" filename. \code{savevector} - Saves a vector into a Pajek ".clu" filename. } \references{ Batagelj, V., & Mrvar. A. (1999). Pajek - Program for Large Network Analysis. Retrieved from 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. } \seealso{ \code{\link{plot.mat}}, \code{\link{critFunC}}, \code{\link{optRandomParC}} } \author{ Vladimir Batagelj & Andrej Mrvar (most functions), \enc{Aleš Žiberna}{Ales Ziberna} (\code{loadnetwork}, \code{loadpajek} and modification of others) } \keyword{file} \keyword{graphs} blockmodeling/man/splitClu.Rd0000644000176200001440000000405014270233277015732 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/splitClu.R \encoding{UTF-8} \name{splitClu} \alias{splitClu} \alias{splitCluRes} \title{Functions creating a list of partitions based on a single partition and information on the number of units in each set.} \usage{ splitClu(clu, n, renumber = FALSE) splitCluRes(res, renumber = FALSE) } \arguments{ \item{clu}{A vector representing a partition of units from different sets. Result of some legacy code for \code{\link{optRandomParC}} or \code{\link{optParC}} or similar functions.} \item{n}{A vector with number of units per set. The assuption is that the first \code{n[1]} elements of \code{clu} are for the first set, the second \code{n[2]} elements of \code{clu} are for the second set and so on. \code{sum(n)} must be equal to \code{length(clu)}.} \item{renumber}{If \code{TRUE}, elements of each partition (for each set) in the list are renumbered to be from 1:"number of clusters" in that partition). Defaults to \code{FALSE}.} \item{res}{Result of (old versions of) functions \code{\link{critFunC}}, \code{\link{optParC}}, \code{\link{optRandomParC}} or similar.} } \value{ A list of partitions if \code{clu}, one for each set of units. A single vector if only one set of units is present. } \description{ Function \code{splitClu} creates a list of partitions based on a single partition (\code{clu}) and information on the number of units in each set (\code{n}). Function \code{splitCluRes} does the same but extracts the information from the result of (old versions of) functions \code{\link{critFunC}}, \code{\link{optParC}}, \code{\link{optRandomParC}} or similar (newer versions should already return a list of partitions in case they are used on networks with more sets of units. } \examples{ n <- c(8,8) clu <- c(rep(1:2, times = c(3, 5)), rep(3:4, times = c(3, 5))) splitClu(clu = clu, n = n ) splitClu(clu = clu, n = n, renumber = TRUE) } \seealso{ \code{\link{clu}}, \code{\link{unlistClu}}, \code{\link{unlistCluInt}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{manip} blockmodeling/man/orderClu.Rd0000644000176200001440000000374114077542615015724 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/orderClu.R \encoding{UTF-8} \name{orderClu} \alias{orderClu} \title{Orders the partition so that mean values of \code{fun} applied to columns (if \code{funWay=2}, default), rows (if \code{funWay=1}) or both (if \code{funWay=c(1,2)}) is decreasing by clusters.} \usage{ orderClu( x, clu = NULL, fun = sum, funWay = 2, nn = NULL, returnList = TRUE, scale = TRUE ) } \arguments{ \item{x}{A result of \code{\link{critFunC}}, \code{\link{optRandomParC}} or similar (something containing M (matrix) and clu (partition)) or a matrix (or array for multirelational networks).} \item{clu}{A partition - a vector or a list of vectors/partitions. It must be supplied only if \code{x} is a matrix or array.} \item{fun}{A function used to summarize rows or columns. \code{sum} by default.} \item{funWay}{In which "way" should \code{fun} be appluied - to columns (if \code{funWay=2}, default), rows (if \code{funWay=1}) or both (if \code{funWay=c(1,2)})} \item{nn}{The numbers of untis by sets of units. In principle, the function should determin this automatically.} \item{returnList}{Logical. Should the partition be returned in form of a list (for lined networks only). \code{TRUE} by default.} \item{scale}{Only used in case of multirelational networks. Should relations be scaled (\code{TRUE} by default) before summation. It can also be a vector of weights by relations.} } \value{ An ordered partition. In an attribute ("reorder"). the information on how things were reordered. } \description{ Orders the partition so that mean values of \code{fun} applied to columns (if \code{funWay=2}, default), rows (if \code{funWay=1}) or both (if \code{funWay=c(1,2)}) is decreasing by clusters. The function can be used on the results of \code{\link{critFunC}}, \code{\link{optRandomParC}} or similar, or matrix and a partition can be supplied. It should also work on multirelational and lined networks. } \seealso{ \code{\link{clu}} } blockmodeling/man/unlistCluInt.Rd0000644000176200001440000000214414270233277016572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unlistCluInt.R \encoding{UTF-8} \name{unlistCluInt} \alias{unlistCluInt} \title{Unlist a partition.} \usage{ unlistCluInt(clu) } \arguments{ \item{clu}{A partition by sets, that is a list of "simple" partitions.} } \value{ The unlisted partition - one vector containing only integers. } \description{ It is used to convert a partition by sets into a single "simple" partition. Simple partition is a partition of only one set, that is a vector where units with the same value are considered to belong to the same cluster. The partitions by sets is a list, where each element of a list is a "simple" partition that corresponds to one set. The function first converts all elements of the lists to integers, that makes sure that each set uses different integers and on the end uses unlist function on such list. } \examples{ cluList<-list(c("a","b","a"),c("b","c","b","c")) unlistCluInt(cluList) cluList<-list(c(1,1,1,2,2,2),c(1,1,1,2,2,2,3,3)) unlistCluInt(cluList) } \seealso{ \code{\link{clu}}, \code{\link{splitClu}}, \code{\link{unlistClu}} } blockmodeling/man/optRandomParC.Rd0000644000176200001440000003034214241707750016647 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/optRandomParC.R, R/printRes.R \encoding{UTF-8} \name{optRandomParC} \alias{optRandomParC} \alias{print.optMorePar} \title{Optimizing a set of partitions based on the value of a criterion function} \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, useParLapply = FALSE, useLB = NULL, chunk.size = 1, cl = NULL, stopcl = is.null(cl), useRegParrallaBackend = FALSE, ... ) \method{print}{optMorePar}(x, ...) } \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 block types. 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 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 inital 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. By default it is set to \code{TRUE} if \code{blocks} is either a vector or a list of vectors and to \code{FALSE} otherwise.} \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{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{useParLapply}{Should \code{parLapplyLB} or \code{parLapply} (see \code{useLB}) be used for parallel execution (on multiple cores). Otherwise \code{mforeach} is used. Defaults to FALSE. If \code{useParLapply = TRUE} and \code{useLB = TRUE}, results are not reproducible.} \item{useLB}{Should be logical if set. Only used if \code{useParLapply = TRUE}. Should load balancing be used (\code{parLapplyLB} instead of \code{parLapply}). Using load balancing usually means faster execution, but results are with not reproducible. Defaults to \code{NULL}, which is changed to \code{TRUE}, but a warning.} \item{chunk.size}{chunk.size used in \code{parLapplyLB} if it is used, otherwise ignored. Defaults to 1.} \item{cl}{The cluster to use (if formed beforehand). Defaults to \code{NULL}. Ignored if useParLapply=FALSE (default) and foreach::getDoParRegistered is true} \item{stopcl}{Should the cluster be stoped after the function finishes. Defaults to \code{is.null(cl)}.} \item{useRegParrallaBackend}{Should the function use already registered parallel backend. Defaults to \code{FALSE}. If \code{TRUE}, you must make sure that an appropriate backend is correctly set up and registered. Use only if \code{useParLapply = FALSE} (default) and \code{nCore} is not 1.} \item{\dots}{Arguments passed to other functions, see \code{\link{critFunC}}.} \item{x}{The result of \code{\link{optRandomParC}}.} \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}.} } \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{optParC}, 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.} } \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). The number of clusters and a number of partitions to generate can be specified (\code{optParC}). } \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). } \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 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 } \references{ Batagelj, V., & Mrvar, A. (2006). Pajek 1.11. Retrieved from 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 } \seealso{ \code{\link{critFunC}}, \code{\link{IM}}, \code{\link{clu}}, \code{\link{err}}, \code{\link{plot.optMorePar}} } \author{ \enc{Aleš, Žiberna}{Ales Ziberna} } \keyword{cluster} \keyword{graphs} blockmodeling/man/plotMat.Rd0000644000176200001440000003470714303451145015560 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.crit.fun.R, R/plot.mat.nm.R, % R/plot.opt.more.par.R, R/plot.opt.more.par.mode.R, R/plot.opt.par.R, % R/plot.opt.par.mode.R, R/plotMat.R \encoding{UTF-8} \name{plot.critFun} \alias{plot.critFun} \alias{plot.crit.fun} \alias{plotMatNm} \alias{plot.optMorePar} \alias{plot.opt.more.par} \alias{plot.optMoreParMode} \alias{plot.opt.more.par.mode} \alias{plot.optPar} \alias{plot.opt.par} \alias{plot.optParMode} \alias{plot.opt.par.mode} \alias{plotMat} \alias{plotArray} \alias{plot.mat} \title{Functions for plotting a partitioned matrix (representing the network)} \usage{ \method{plot}{critFun}(x, main = NULL, ...) \method{plot}{crit.fun}(x, main = NULL, ...) plotMatNm( M = x, x = M, ..., main.title = NULL, title.row = "Row normalized", title.col = "Column normalized", main.title.line = -2, par.set = list(mfrow = c(1, 2)) ) \method{plot}{optMorePar}(x, main = NULL, which = 1, ...) \method{plot}{opt.more.par}(x, main = NULL, which = 1, ...) \method{plot}{optMoreParMode}(x, main = NULL, which = 1, ...) \method{plot}{opt.more.par.mode}(x, main = NULL, which = 1, ...) \method{plot}{optPar}(x, main = NULL, which = 1, ...) \method{plot}{opt.par}(x, main = NULL, which = 1, ...) \method{plot}{optParMode}(x, main = NULL, which = 1, ...) \method{plot}{opt.par.mode}(x, main = NULL, which = 1, ...) plotMat( x = M, clu = NULL, orderClu = FALSE, M = x, 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.width.newSet = par.line.width[1] * 2, par.line.col = "blue", par.line.col.newSet = "red", 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, MplotValues = NULL, ... ) plotArray( x = M, M = x, IM = NULL, ..., main.title = NULL, main.title.line = -2, mfrow = NULL ) \method{plot}{mat}( x = M, clu = NULL, orderClu = FALSE, M = x, 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.width.newSet = par.line.width[1] * 2, par.line.col = "blue", par.line.col.newSet = "red", 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, MplotValues = NULL, ... ) } \arguments{ \item{x}{A result from a corresponding function or a matrix or similar object representing a network.} \item{main}{Main title.} \item{\dots}{Additional arguments to \code{plot.default} for \code{plotMat} and also to \code{plotMat} for other functions.} \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{main.title}{Main title in \code{plotArray} version.} \item{title.row}{Title for the row-normalized matrix in nm version} \item{title.col}{Title for the column-normalized matrix in nm version} \item{main.title.line}{The line in which main title is printed in \code{plotArray} 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{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/set.} \item{orderClu}{Should the partition be ordered before plotting. \code{FALSE} by default. If \code{TRUE}, \code{\link{orderClu}} is used (using default arguments) to order the clusters in a partition in "decreasing" (see \code{\link{orderClu}} for interpretation) order.} \item{ylab}{Label for y axis.} \item{xlab}{Label for x axis.} \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.width.newSet}{The width of the line that separates that separates the sets/modes - only used when \code{clu} is a list and \code{par.line.width} has length 1.} \item{par.line.col}{The color of the line that separates the partitions.} \item{par.line.col.newSet}{The color of the line that separates that separates the sets/modes - only used when \code{clu} is a list and \code{par.line.col} has length 1.} \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{colLabels}{Should the labels of units be colored. If \code{FALSE}, these are not colored, if \code{TRUE}, they are colored with colors of clusters as defined by palette. This can be also a vector of colors (or integers) for one-mode networks or a list of two such vectors for two-mode networks.} \item{MplotValues}{A matrix to strings to plot in cells. Only to be used if other values than those in the original matrix (\code{x} or \code{M} arguments) should be used. Defaults to \code{NULL}, in which case the valued from original matrix are plotted (if this is not prevented by some other arguments). Overrides all other arguments that deal with cell values (e.g. \code{print.digits.cells}). Sets \code{print.val} to \code{TRUE} and \code{plot.legend} to \code{FALSE}.} \item{mfrow}{\code{mfrow} Argument to \code{par} - number of row and column plots to be plotted on one figure.} } \value{ The functions are used for their side effect - plotting. } \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{plotArray} plots an array. \code{plot.mat.nm} has been replaced by \code{plotMatNm}. } \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" } \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 } \seealso{ \code{\link{critFunC}}, \code{\link{optRandomParC}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{graphs} \keyword{hplot} blockmodeling/man/ircNorm.Rd0000644000176200001440000000237413677022067015556 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ircNorm.R \name{ircNorm} \alias{ircNorm} \title{Function for iterated row and column normalization of valued matrices} \usage{ ircNorm(M, eps = 10^-12, maxiter = 1000) } \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. } \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. } \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) } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{manip} blockmodeling/man/RF.Rd0000644000176200001440000000434114306422612014436 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RF.R \encoding{UTF-8} \name{RF} \alias{RF} \title{Calculate the value of the Relative Fit function} \usage{ RF(res, m = 10, loops = NULL) } \arguments{ \item{res}{An object returned by the function \code{optRandomParC}.} \item{m}{The number of randomized networks for the estimation of the expected value of a criterion function. It has to be as high as possible. Defaults to 10.} \item{loops}{Whether loops are treated the same as any other values or not.} } \value{ \itemize{ \item \code{RF} - The value of the Relative Fit function. \item \code{err} - The value of a criterion function that is used for blockmodeling (for empirical network). \item \code{rand.err} - A vector with the values of the criterion function that is used for blockmodeling (for randomized networks). } } \description{ The function calculates the value of the Relative Fit function. Currently implemented only for one-relational one-mode or two-mode networks. } \details{ The function randomizes an empirical network to compute the value of the Relative Fit function. The networks are randomized in such a way that the values on the links are randomly relocated. Other approaches to randomization also exist and might be more appropriate in some cases, see Cugmas et al. (2021). } \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) res <- optRandomParC(M = net, k = 2, rep = 10, approaches = "hom", homFun = "ss", blocks = "com") RF(res = res, m = 100, loops = TRUE) } \references{ Cugmas, M., Žiberna, A., & Ferligoj, A. (2021). The Relative Fit measure for evaluating a blockmodel. Statistical Methods & Applications, 30(5), 1315-1335. \doi{10.1007/s10260-021-00595-1} } \seealso{ \code{optRandomParC} } \author{ Marjan Cugmas and Aleš Žiberna } blockmodeling/man/canClu.Rd0000644000176200001440000000201614076015230015327 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/canClu.R \encoding{UTF-8} \name{canClu} \alias{canClu} \alias{canCluUniqe} \title{Create canonical partition and find unique canonical partitions in a list of partitions.} \usage{ canClu(clu) canCluUniqe(cluList) } \arguments{ \item{clu}{A partition - a vector or a list of vectors/partitions.} \item{cluList}{A list of partitions(vectors).} } \value{ For function \code{canClu} - a canonical partition or a list of such partitions. For function \code{canCluUniqe} - A list of unique canonical partitions. } \description{ It is used to convert any partition to a canonical partition. A canonical partition is a partition where the first unit is in cluster 1, the next unit that is not in cluster 1 in in cluster 2 and so on. So if we would take first appearances of clusters in the order they appear in the partition vector, we would get integers from 1 to the number of clusters. } \examples{ clu<-c(3,2,2,3,1,2) canClu(clu) } \seealso{ \code{\link{clu}} } blockmodeling/man/relInv.Rd0000644000176200001440000000135714026571742015402 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/relInv.R \encoding{UTF-8} \name{relInv} \alias{relInv} \alias{relInv2} \title{Functions for computing "relative inverse" (\code{x[1]/x}).} \usage{ relInv(x) relInv2(x) } \arguments{ \item{x}{A numeric vector. For \code{relInv} it should not contain 0s (while for \code{relInv2} it can).} } \value{ A vector computed as \code{x[1]/x}. For \code{relInv2}, if the non-finite elements are replaced with 0s. } \description{ For a vector x, it computes \code{x[1]/x}. For \code{relInv2}, if certain elements of the result are not finite (e.g. if certain elements of x are 0), these elements are replaced with 0s. } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{manip} blockmodeling/man/printBlocks.Rd0000644000176200001440000000131414306412566016425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/printBlocks.R \encoding{UTF-8} \name{printBlocks} \alias{printBlocks} \title{Nice printing of the \code{blocks} parameter as used in \code{\link{optRandomParC}} and \code{\link{critFunC}}.} \usage{ printBlocks(blocks) } \arguments{ \item{blocks}{\code{blocks} parameter as used in \code{\link{optRandomParC}} and \code{\link{critFunC}}.} } \value{ Used for side effects (printing) } \description{ Nice printing of the \code{blocks} parameter as used in \code{\link{optRandomParC}} and \code{\link{critFunC}}. } \seealso{ \code{\link{optRandomParC}}, \code{\link{critFunC}} } \author{ \enc{Aleš, Žiberna}{Ales Ziberna} } \keyword{print} blockmodeling/DESCRIPTION0000644000176200001440000000222714471422772014606 0ustar liggesusersPackage: blockmodeling Type: Package Title: Generalized and Classical Blockmodeling of Valued Networks Version: 1.1.5 Date: 2023-08-23 Imports: stats, methods, Matrix, parallel Suggests: sna, doRNG, doParallel, foreach Depends: R (>= 2.10) Authors@R: c(person(given = "Aleš", family = "Žiberna", email = "ales.ziberna@gmail.com", role = c("aut", "cre")), person( family ="Cugmas", given = "Marjan", email = "marjan.cugmas@fdv.uni-lj.si", role = c("ctb"))) 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 NeedsCompilation: yes Packaged: 2023-08-23 11:24:46 UTC; zibernaa Author: Aleš Žiberna [aut, cre], Marjan Cugmas [ctb] Repository: CRAN Date/Publication: 2023-08-23 15:30:02 UTC blockmodeling/build/0000755000176200001440000000000014471366176014201 5ustar liggesusersblockmodeling/build/partial.rdb0000644000176200001440000000007514471366176016330 0ustar liggesusersb```b`abd`b1 H020piּb C"wa7blockmodeling/tests/0000755000176200001440000000000014362271060014226 5ustar liggesusersblockmodeling/tests/tests.R0000644000176200001440000000305614346350477015533 0ustar liggesuserslibrary(blockmodeling) nCores<-1 clu <- c(1, 2, 1, 2, 1, 3, 2, 1, 1, 1, 1, 1, 3, 2, 4, 3, 4, 2, 2, 3) data(baker) set.seed(2022) res<-optRandomParC(baker>0,k=4, approaches = "bin", blocks = c("nul","com"),rep = 100, nCores = nCores) plot(res) print(res) resSS<-optRandomParC(baker>0,k=4, approaches = "hom", blocks = c("nul","com"),rep = 100, nCores = nCores) plot(resSS) print(resSS) resBll<-optRandomParC(baker>0,k=4, approaches = "hom", blocks = c("nul","com"),rep = 100, nCores = nCores, homFun="bll") plot(resBll) print(resBll) # if(requireNamespace("StochBlockTest")){ # StochBlockTest::llStochBlock(baker>0, clu=clu(resBll), addOne = FALSE, diagonal = "seperate") # resSB<-StochBlockTest::stochBlockORP(baker>0,k = 4, rep = 100, addOne = FALSE, diagonal = "seperate") # err(resSB) # plot(resSB) # crand(clu(resSB),clu(resBll)) # } tmp<-critFunC(baker>0, clu=clu, approaches = "hom", blocks = c("nul","rre"),homFun="bll", mulReg = TRUE) plot(tmp) tmp[["IM"]][1,,] tmp[["EM"]][1,,] tmp<-critFunC(baker>0, clu=clu, approaches = "hom", blocks = c("nul","com"),homFun="bll", mulReg = TRUE) tmp$EM[1,,] tmp$err plot(tmp) critFunC(baker>0, clu=clu, approaches = "hom", blocks = c("nul","com"),homFun="bll", mulReg = TRUE, diag=2)$err #if(requireNamespace("StochBlockTest")) StochBlockTest::llStochBlock(baker>0, clu=clu,addOne = FALSE) clu2L<-list(rep(1:2, each=5),rep(1:2, each=5)) tmp<-critFunC(baker>0, clu=clu2L, approaches = "hom", blocks = c("nul","com"),homFun="bll", mulReg = TRUE) tmp$EM[1,,] tmp$err blockmodeling/src/0000755000176200001440000000000014471366176013671 5ustar liggesusersblockmodeling/src/REGE_OWNM_R.f900000644000176200001440000000440113677022067016046 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.f900000644000176200001440000000405513677022067015605 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.f900000644000176200001440000000462313677022067016640 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.f900000644000176200001440000000564713677022067015605 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.f900000644000176200001440000000577213677022067015603 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.c0000644000176200001440000000715614237443266015005 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 *, 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 *, 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 *, 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, 32}, {"optPar", (DL_FUNC) &optPar, 39}, {"optParMulti", (DL_FUNC) &optParMulti, 44}, {"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_blockmodelingRoxygen2(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, FortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } blockmodeling/src/REGD_R.f900000644000176200001440000000467713677022067015224 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.f900000644000176200001440000000573313677022067015623 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.f900000644000176200001440000000553413677022067016172 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.f900000644000176200001440000000614113677022067016200 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.f900000644000176200001440000000456713677022067015630 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.f900000644000176200001440000000705213677022067016201 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.f900000644000176200001440000000427713677022067016377 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.f900000644000176200001440000000411713677022067015212 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.c0000644000176200001440000034205414323232002016731 0ustar liggesusers/* WARNINGS: rdo and cdo blocks added only to binary and valued blockmodeling - these blocks return Inf for homogeneity blockmodeling! 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 optimizing - eg. not only local search, but also genetic 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 3 #define nBlockTypes 11 #define nApproaches 3 /* #define MaxNumOfDiffBlockTypes 10 */ #define min(a,b) ((a) < (b) ? (a) : (b)) #define max(a,b) ((a) > (b) ? (a) : (b)) const double eps = 0.001; 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 binary log-likelihood with probability equal to density*/ double bll(double *px, int n, double preSpecVal) { double p=0; double res=0; int i; for(i=0;i (1- eps)) {p = 1-eps;} for(i=0;i (1- eps)) {p = 1-eps;} for(i=0;i p){ p=preSpecVal; } if(p < eps) {p=eps;} if(p > (1- eps)) {p = 1-eps;} 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, const int *pmulReg){ return(0.0); } /* a function for computing error of the block that always returns Inf*/ double infBlock(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, const int *pmulReg){ return(INFINITY); } /* 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, const int *pmulReg){ /* 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); if(*pmulReg==1) { return((nrb-nnr)*ncb + (ncb-nnc)*nnr); } else { return((nrb-nnr) + (ncb-nnc)); } } /* 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, const int *pmulReg){ /* 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); } if(*pmulReg==1) { return((ncb-nnc)*nrb); } else { return(ncb-nnc); } } /* 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, const int *pmulReg){ /* 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); } if(*pmulReg==1) { return((nrb-nnr)*ncb); } else { return((nrb-nnr)); } } /* a function for computing error of the row-dominant block - binary blockmodeling*/ double binRdo(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, const int *pmulReg){ /* 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; double mrs=0; for(int i = 0; i0); st += prs; } if(*pmulReg==1) { return(st - nnr + (nrb-nnr)*ncb); } else { return(st - nnr + (nrb-nnr)); } } /* 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, const int *pmulReg){ /* 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; } if(*pmulReg==1) { return(st - nnc + (ncb-nnc)*nrb); } else { return(st - nnc + (ncb-nnc)); } } /* 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, const int *pmulReg){ double res=0; int baseInd=relN*nr*nc; int ind2d; for(int j = 0; jprs){mrd = prs; } } if(*pmulReg==1) { return((mrd)*ncb); } else { return((mrd)); } } /* a function for computing error of the row-dominant - binary blockmodeling - diagonal*/ double valRdoDiag(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, const int *pmulReg){ /* 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; double mrd=0; double resDiag=0.0; double tmp; for(int i = 0; i resDiag)){ prs += resDiag; }else{ prs +=tmp; } } if(mrd>prs){mrd = prs;} } if(*pmulReg==1) { return((mrd)*ncb); } else { return((mrd)); } } /* a function for computing error of the row-dominant block - binary blockmodeling - ignore diagonal*/ double valRdoIgnoreDiag(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, const int *pmulReg){ /* 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 mrd - minimal row deviation */ int baseInd=relN*nr*nc; double prs=0; double mrd=0; for(int i = 0; iprs){mrd = prs; } } if(*pmulReg==1) { return((mrd)*ncb); } else { return((mrd)); } } /* a function for computing error of the row-dominant block - binary blockmodeling*/ double valCdo(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, const int *pmulReg){ /* 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 mcd - minimal row deviation */ int baseInd=relN*nr*nc; int ind2d; double pcs=0; double mcd=0; for(int j = 0; j resDiag)){ pcs += resDiag; }else{ pcs +=tmp; } } if(mcd0){ // Rprintf("True\n"); // for(int iColClu=0;iColClu<*pnColClus;iColClu++){ for(int iRowClu=0;iRowClu<*pnRowClus;iRowClu++){ // Rprintf("iRowClu = %i\n", iRowClu); // Rprintf("pnUnitsRowClu[iRowClu] = %i\n", pnUnitsRowClu[iRowClu]); // Rprintf("pnrInSetByClusters[iRowClu] = %i\n", pnrInSetByClusters[iRowClu]); *perr += -pnUnitsRowClu[iRowClu]*log(pnUnitsRowClu[iRowClu]*1.0/pnrInSetByClusters[iRowClu]); // Rprintf("err = %.3f\n", *perr); } } free(pEMarrAllRel); /*Rprintf("critFun - end \n");*/ } /* the function below converts an array representation of a partition to a vector representation of a partition */ void parArr2Vec(const int *pn, const int *pnClus, const int *pnUnitsClu, const int *pParArr, int *pParVec){ /*pParVec = (int *) malloc((*pn)*sizeof(int));*/ for(int iClu=0;iClu<*pnClus;iClu++){ for(int iCluUnit=0;iCluUnit=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, const int *pmulReg, const int *pnrInSetByClusters){ /* 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 elements 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 number of members of each row cluster int *pnUnitsColClu - pointer to the array of the number 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 specifying approach - one for each relation int *pmaxBlockTypes - pointer to maximum number of used block types int *pnBlockTypeByBlock - pointer to 3d array (Rel, row, col) specifying the number of used allowed block types int *pblocks - pointer to the 4d array (nBlockTypesByBlock, Rel, row, col) specifying allowed block types int *pIM - pointer to 3d array (Rel, row, col) specifying the image matrix double *pEM - pointer to 3d array (Rel, row, col) specifying the error for each block double *pEarr - pointer to the 4d array ((*pmaxBlockTypes), Rel, row, col) specifying 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 occurred int *pcolCluChange - pointer to an array holding the col row clusters where the change occurred int *psameIM - pointer to 0 (false) or 1 (true) specifying if the image has to be the same for all relations int *pregFun - pointer to the 4d array ((*pmaxBlockTypes), Rel, row, col) specifying 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) specifying weather a the pre-specified value should be used when computing inconsistency double *ppreSpecM - pointer to 4d array ((*pmaxBlockTypes), Rel, row, col) specifying 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 dimensions as blocks int *pexchageClusters - pointer to a matrix (nRowClust, nColClus) showing which clusters are exchangeable int *pnrInSetByClusters - pointer to the vector of sizes of sets for row clusters. The length of the vector is equal to the number of row clusters and gives the number of units in a set to which a given row cluster belongs to. Should be set to vector of 0s if ll for group sizes should not be computed. */ /*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, pmulReg, pnrInSetByClusters); /*Rprintf("Initial error = %.2f\n", *perr);*/ /* prepare temporary 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, pmulReg, pnrInSetByClusters); /*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 permanent 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, pmulReg, pnrInSetByClusters); /*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 poskusam narediti tako, da bo program sel cez vsa mozna razbitja in shranil doloceno stevilo najboljsih Torej da se zanka ne bo zakljucila, ko se bo naslo prvo boljse razbitje Pazi da bos popravil spremembe, tako tko spodaj, na zactku iteracije pa jih je potrebno ponovno udejanjiti!!! Mogoce 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/critFunC.R0000644000176200001440000011141014303406400015114 0ustar liggesusers#' @encoding UTF-8 #' @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. #' #' @param 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. #' @param 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. #' @param 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"}. #' @param 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 block types. 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 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. #' @param isTwoMode \code{1} for one-mode networks and \code{2} for two-mode networks. The default value is set to \code{NULL}. #' @param isSym Specifying if the matrix (for each relation) is symmetric. #' @param diag Should the special status of diagonal be acknowledged. A single number or a vector equal to the number of relation. The default value is set to \code{1}. Codes: \cr #' \code{0} - diagonal is treated in the same way as other values \cr #' \code{1} - diagonal is treated separately, or \cr #' \code{2} - diagonal values are ignored. \cr #' @param IM The obtained image for objects. For debugging purposes only. #' @param EM Block errors by blocks. For debugging purposes only. #' @param 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. #' @param justChange Value specifying if only the errors for changed clusters should be computed. Used only for debugging purposes by developers. #' @param rowCluChange An array holding the two row clusters where the change occured. Used only for debugging purposes by developers. #' @param colCluChange An array holding the col row clusters where the change occured. Used only for debugging purposes by developers. #' @param sameIM Should we demand the same blockmodel image for all relations. The default value is set to \code{FALSE}. #' @param 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"}. #' @param homFun In case of homogeneity blockmodeling two variability criteria can be used: \code{"ss"} - sum of squares (set by default), \code{"ad"} - absolute deviations and \code{"bll"} - - (minus) binary log-likelihood. #' @param usePreSpecM Specifying weather a pre-specified value should be used when computing inconsistency. #' @param preSpecM Sufficient 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}. #' @param save.initial.param Should the inital parameters (\code{approaches}, ...) be saved. The default value is \code{TRUE}. #' @param relWeights Weights for all type of relations in a blockmodel. The default value is set to \code{1}. #' @param 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. #' @param blockTypeWeights Weights for each type of block used, if they are to be different across block types (see \code{blocks} above). It must be suplied in form of a named vector, 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}. #' @param 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). #' @param returnEnv Should the function also return the environment after its completion. #' @param mulReg Should the errors that apply to rows/columns (and not to cells) should be multiplied by number of rows/columns. Defaults to TRUE. #' @param addGroupLlErr Used only when stochastic generalized blockmodeling is used. Should the total error included the part based on sizes of groups. Defaults to TRUE. Will return wrong results for two-mode networks if critFunC is called directly (should be fine if called via optParC function). #' #' #' #' @return #' \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 #' #' @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 #' 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 #' set.seed(1) #' 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 #' 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) #' #' # Optimizing one partition #' res <- optParC(M = net, clu = clu.rnd, #' approaches = "hom", homFun = "ss", blocks = "com") #' plot(res) # Hopefully we get the original partition #' #' @author \enc{Aleš, Žiberna}{Ales Ziberna} #' @seealso \code{\link{optRandomParC}}, \code{\link{IM}}, \code{\link{clu}}, \code{\link{err}}, \code{\link{plot.critFun}} #' @keywords cluster graphs #' @import methods #' #' @export ########## 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, mulReg=TRUE, addGroupLlErr=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 uniqueBlocks<-unique(unlist(unclass(blocks))) if(all(is.na(uniqueBlocks))) stop("No block types are specified!") blocksOk<-uniqueBlocks%in%c(cStatus$blockTypes,NA) if(all(blocksOk)==FALSE) { stop("Block types ", paste(uniqueBlocks[!blocksOk], collapse=", ")," are not supported!") } 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)&& (length(clu)==2)&& (sum(sapply(clu, length))==sum(dim(M)[1:2])) } if(is.list(clu)){ tmNclu<-sapply(clu,function(x)length(unique(x))) tmN<-sapply(clu,length) # for(iMode in 2:nMode){ # clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) # } # clu<-unlist(clu) } else { tmNclu<-length(unique(clu)) tmN<-length(clu) } if(!isTwoMode && is.list(clu)){ if(sum(sapply(clu, length))==dim(M)[1]) { newClu<-c() tmpMaxClu<-0 for(iClu in clu){ iClu<- as.integer(as.factor(iClu))+tmpMaxClu tmpMaxClu <- max(iClu) newClu<-c(newClu,iClu) } clu <- newClu } else { stop("Clu does not seem to be compatible with M!") } } 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(addGroupLlErr && homFun=="bll"&&(!isTwoMode)){ nrInSetByClusters<-rep(tmN, tmNclu) } else { nrInSetByClusters <- as.double(rep(0,nRCclu[1])) } 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(any(dB!=c(maxBlockTypes,dM[3],nRCclu))) stop("array ('blocks' argument) has a wrong dimensions of dimensions") 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])){ M[,,i]<-(M[,,i]>=tmpPreSpecM[1])*1 } else stop("Relation ",i," is not binary but supplied 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, mulReg=as.integer(mulReg), nrInSetByClusters= as.integer(nrInSetByClusters), 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)<-"critFun" return(res) } #' @rdname critFunC #' #' @param nMode Number of nodes. If \code{NULL}, then determined from \code{clu}. #' @param 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. #' @param maxPar The number of partitions with optimal criterion fuction to be returned. Only used If \code{useMulti} is \code{TRUE}. #' @param minUnitsRowCluster Minimum number of units in row cluster. #' @param minUnitsColCluster Minimum number of units in col cluster. #' @param maxUnitsRowCluster Maximum number of units in row cluster. #' @param maxUnitsColCluster Maximum number of units in col cluster. #' @param 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. #' @param fixClusters Clusters to be fixed. Used only if \code{exchageClusters = "all"}. A vector of integers that specify clusters to be fixed, where clusters are numbered from 1 to the total (in all modes or sets) number of clusters. #' #' @export 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",fixClusters = NULL, save.initial.param=TRUE, mulReg=TRUE, addGroupLlErr=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 uniqueBlocks<-unique(unlist(unclass(blocks))) if(all(is.na(uniqueBlocks))) stop("No block types are specified!") blocksOk<-uniqueBlocks%in%c(cStatus$blockTypes,NA) if(all(blocksOk)==FALSE) { stop("Block types ", paste(uniqueBlocks[!blocksOk], collapse=", ")," are not supported!") } 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) } } else { tmN<-length(clu) tmNclu<-length(unique(clu)) } 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) if(addGroupLlErr && homFun=="bll"){ nrInSetByClusters<-rep(tmN, tmNclu) } else { nrInSetByClusters <- as.double(rep(0,nRCclu[1])) } 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]) } exchageClusters[fixClusters,]<-as.integer(0) exchageClusters[,fixClusters]<-as.integer(0) } 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 dimensions") }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") } else stop("array ('blocks' argument) has a wrong dimensions") } } else if(length(dim(blocks))==3){ maxBlockTypes<-dim(blocks)[1] blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) if(any(dim(blocks)!=c(maxBlockTypes,nRCclu))){ if(nMode==2 & (sum(dim(blocks)[c(2,3)])==nRCclu)){ for(i in 1:dM[3]){ blocksArr[,i,1:tmNclu[1],(tmNclu[1]+1):sum(tmNclu)]<-blocks } blocksArr[1,,(tmNclu[1]+1):sum(tmNclu),]<-"dnc" blocksArr[1,,1:tmNclu[1],1:tmNclu[1]]<-"dnc" } else stop("array ('blocks' argument) has a wrong dimensions") } else { 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)) if(any(dim(blocks)!=nRCclu)){ if(nMode==2& (sum(dim(blocks))==nRCclu)){ for(i in 1:dM[3]){ blocksArr[1,i,1:tmNclu[1],(tmNclu[1]+1):sum(tmNclu)]<-blocks } blocksArr[1,,(tmNclu[1]+1):sum(tmNclu),]<-"dnc" blocksArr[1,,1:tmNclu[1],1:tmNclu[1]]<-"dnc" } else stop("array ('blocks' argument) has a wrong dimensions") }else { for(i in 1:dM[3]){ blocksArr[1,i,,]<-blocks } } blocks<-blocksArr } else stop("array ('blocks' argument) has a wrong number of dimensions") } dB<-dim(blocks) if(any(dB!=c(maxBlockTypes,dM[3],nRCclu))) stop("array ('blocks' argument) has a wrong dimensions of dimensions") 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 inappropriate 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])){ M[,,i]<-(M[,,i]>=tmpPreSpecM[1])*1 } else stop("Relation ",i," is not binary but supplied 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, mulReg=as.integer(mulReg), nrInSetByClusters = as.integer(nrInSetByClusters), 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, mulReg=as.integer(mulReg), nrInSetByClusters = as.integer(nrInSetByClusters), 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) } #' @useDynLib blockmodeling, .registration = TRUEblockmodeling/R/genRandomPar.R0000644000176200001440000001110214112156366015764 0ustar liggesusers#' The function for generating random partitions #' #' 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)) #' #' @param k Number of clusters (by modes). #' @param n Number of units (by modes). #' @param seed Seed for generating random numbers (partitions). #' @param mingr Minimal allowed group size. #' @param maxgr Maximal allowed group size. #' @param 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). #' #' @return 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 http://vlado.fmf.uni-lj.si/pub/networks/pajek/ #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' @keywords cluster #' #' @export "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.R0000644000176200001440000000005313677022067014705 0ustar liggesusers"useneg" <- function(x)ifelse(x<0,x,0) blockmodeling/R/sedist.R0000644000176200001440000003106414257652061014716 0ustar liggesusers#' @encoding UTF-8 #' @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", ...) #' #' @param M A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network must be one-mode. #' @param 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). #' @param fun Which function should be used to compute distances (given as a character). #' @param 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}). #' @param 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" #' @param 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}. #' @param \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". #' #' @return 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)) #' #' @keywords cluster graphs #' @importFrom stats as.dist cor cov na.omit #' #' @export "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(inherits(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.R0000644000176200001440000000420213677022067014430 0ustar liggesusers#' @rdname REGE #' #' @export "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.R0000644000176200001440000004030713677022067015015 0ustar liggesusers#' @rdname REGE #' #' @export REGE.for<-function( M, #netowrk in form of a matrix or array (in case of several relations) iter = 3, E = 1 #initial similiarity between vertices (default 1 among all vertices). ){ if(is.array(M)){ dM<-dim(M) dnM<-dimnames(M) N<-dM[1] if (length(dM)==3) { NR<-dM[3] } else { if(length(dM)==2) { NR<-1 } else stop("An array has wrong dimensions") } } else stop("M must be an array") M<-structure(as.double(M),dim=dM) dimnames(M)<-dnM E<-matrix(E,ncol=N, nrow=N) 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE #' #' @export 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)) } #' @rdname REGE 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/canClu.R0000644000176200001440000000303414076015220014611 0ustar liggesusers#' @encoding UTF-8 #' @title Create canonical partition and find unique canonical partitions in a list of partitions. #' #' @description #' It is used to convert any partition to a canonical partition. A canonical partition is a partition where the first unit is in cluster 1, the next unit that is not in cluster 1 in in cluster 2 and so on. So if we would take first appearances of clusters in the order they appear in the partition vector, we would get integers from 1 to the number of clusters. #' #' @param clu A partition - a vector or a list of vectors/partitions. #' @param cluList A list of partitions(vectors). #' @return For function \code{canClu} - a canonical partition or a list of such partitions. #' For function \code{canCluUniqe} - A list of unique canonical partitions. #' @seealso \code{\link{clu}} #' @examples #' clu<-c(3,2,2,3,1,2) #' canClu(clu) #' @export canClu<-function(clu){ if(!is.list(clu)){ return(as.numeric(factor(clu,levels=unique(clu)))) } else { lapply(clu, canClu) } } #' @rdname canClu #' #' @export canCluUniqe<-function(cluList){ if(!is.list(cluList)){ stop("cluList must be a list of partitions!") } else { uniqueClu<-NULL uniqueCluStr<-NULL cluList<-lapply(cluList, canClu) cluListStr<-sapply(cluList, paste, collapse=",") for(i in 1:length(cluList)){ if(!(cluListStr[i]%in%uniqueCluStr)){ uniqueClu<-c(uniqueClu,cluList[i]) uniqueCluStr<-c(uniqueCluStr,cluListStr[i]) } } return(uniqueClu) } }blockmodeling/R/rand-multiple.R0000644000176200001440000001175114024134564016174 0ustar liggesusers#' @encoding UTF-8 #' @title Comparing partitions on one or multiple sets of units #' #' @description #' Rand Index and Rand Index corrected/adjusted for chance for comparing partitions (Hubert & Arabie, 1985). The functions also support computing these indices on partitions on multiple sets (where a "combined" partition is a list of multiple partitions). #' The names of the clusters do not matter. #' #' # #' @usage # #' rand(clu1, clu2, tab) # #' crand(clu1, clu2, tab) #' #' @param clu1 The first of the two partitions to be compared, given in the form of vectors, where for each unit a cluster membership is given. Alternatively, this can be a contingency table obtained as a \code{table(clu1, clu2)}. If a partition, \code{clu2} must also be provided. In case of multiple sets, this should be pa list of partitions. #' @param clu2 If \code{clu1} is partition or a list of partitions, this must be a comaptible the second partition or list of partitions. #' @param tab A contingency table obtained as a \code{table(clu1, clu2)}. This is included for back-compatibility reasons. If this is present, all other arguments are ignored. #' @param multiSets How should we compute the index in case of multiple sets of unis (if \code{clu1} and \code{clu2} are lists of partitions)? Possible values are "unlist" and "weight" (the default). #' @param weights Weights to be used if \code{multiSets} is "weight". It can be "equal", "size" (default) or a numeric (non-negative) vector of the same length as the number of sets (the number of partitions in the list of partitions). #' @param returnIndividual If \code{multiSets} is "weight", should the indices for individual sets be also returned. If \code{TRUE}, the function returns a list instead of a single value. If the values is \code{"attr"} (the default), the indices by sets are given as an attribute \code{"bySets"} #' #' @return The value of Rand Index (corrected/adjusted for chance) unless \code{multiSets="weight"} and \code{returnIndividual=FALSE}. In this case, a list with two items is return. The "global" index is in \code{global}, while the the indices by sets are in \code{bySets}. #' #' @references Hubert, L., & Arabie, P. (1985). Comparing Partitions. Journal of Classification, 2(1), 193-218. #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' @keywords cluster #' #' @export "rand" <- function (clu1, clu2, tab) #Hubert & Arabie { if(missing(tab))if(is.table(clu1)){ tab<-clu1 } else tab<-table(clu1,clu2) n <- sum(tab) 1 + (sum(tab^2) - (sum(rowSums(tab)^2) + sum(colSums(tab)^2))/2)/choose(n, 2) } #' @rdname rand #' #' @export "crand" <- function (clu1,clu2, tab, multiSets=c("weights","unlist"), weights = c("size","equal"), returnIndividual="attr") #Hubert & Arabie { if(missing(tab)) if(is.table(clu1)){ tab<-clu1 } else { if(is.list(clu1)){ if(!is.list(clu2)|(length(clu1)!=length(clu2))) stop("If clu1 is a list, clu2 must be a list of equal size!") multiSets<-match.arg(multiSets) if(multiSets=="unlist"){ tab<-table(unlistCluInt(clu1),unlistCluInt(clu2)) }else if(multiSets=="weights"){ if(is.numeric(weights)){ if(length(weights)!=length(clu1)) stop("Weigts must equal the number of sets") } else { weights<-match.arg(weights) if(weights=="equal") { weights<-rep(1,length(clu1)) } else if(weights=="size"){ weights<-sapply(clu1,length) } else stop("Unexpected 'weights' argument!") } bySets<-mapply(crand2, clu1, clu2) global<-sum(bySets*weights)/sum(weights) if(returnIndividual=="attr"){ attr(global,"bySets")<-bySets return(global) } else if(returnIndividual==TRUE){ return(list(global=global, bySets=bySets)) } else if(returnIndividual==FALSE){ return(global) } else stop("Unexpected 'returnIndividual' argument!") } else stop("Unexpected 'multiSets' argument!") } else 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)) } #' @rdname rand #' #' @export "rand2" <- function (clu1, clu2) #Hubert & Arabie { # .Deprecated("rand") tab<-table(clu1,clu2) n <- sum(tab) 1 + (sum(tab^2) - (sum(rowSums(tab)^2) + sum(colSums(tab)^2))/2)/choose(n, 2) } #' @rdname rand #' #' @export "crand2" <- function (clu1,clu2) #Hubert & Arabie { # .Deprecated("crand") 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/loadvector.R0000644000176200001440000000103613677022067015563 0ustar liggesusers#' @rdname Pajek #' #' @description \code{loadvector} - Loads a Pajek ".clu" filename as a vector. #' @importFrom utils read.table #' #' @export "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/plotMat.R0000644000176200001440000010371314426412000015025 0ustar liggesusers#' @encoding UTF-8 #' @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{plotArray} plots an array. \code{plot.mat.nm} has been replaced by \code{plotMatNm}. #' #' @param x A result from a corresponding function or a matrix or similar object representing a network. #' @param 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/set. #' @param orderClu Should the partition be ordered before plotting. \code{FALSE} by default. If \code{TRUE}, \code{\link{orderClu}} is used (using default arguments) to order the clusters in a partition in "decreasing" (see \code{\link{orderClu}} for interpretation) order. #' @param 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. #' @param ylab Label for y axis. #' @param xlab Label for x axis. #' @param main Main title. #' @param print.val Should the values be printed in the matrix. #' @param print.0 If \code{print.val = TRUE} Should the 0s be printed in the matrix. #' @param plot.legend Should the legend for shades be plotted. #' @param print.legend.val Should the values be printed in the legend. #' @param print.digits.legend The number of digits that should appear in the legend. #' @param print.digits.cells The number of digits that should appear in the cells (of the matrix and/or legend). #' @param 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. #' @param outer.title Should the title be printed on the 'inner' or 'outer' margin of the plot, default is 'inner' margin. #' @param title.line The line (from the top) where the title should be printed. The suitable values depend heavily on the displayed type. #' @param 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}. #' @param cex.val The size of the values printed. The default is \code{10 / 'number of units'}. #' @param val.y.coor.cor Correction for centering the values in the squares in y direction. #' @param val.x.coor.cor Correction for centering the values in the squares in x direction. #' @param cex.legend Size of the text in the legend. #' @param legend.title The title of the legend. #' @param cex.axes Size of the characters in axes. Default makes the cex so small that all categories can be printed. #' @param print.axes.val Should the axes values be printed. Default prints each axis if \code{rownames} or \code{colnames} is not \code{NULL}. #' @param 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}. #' @param 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}. #' @param x.axis.val.pos The x coordinate of the y axis values. #' @param y.axis.val.pos The y coordinate of the x axis values. #' @param cex.main Size of the text in the main title. #' @param cex.lab Size of the text in matrix. #' @param yaxis.line The position of the y axis (the argument 'line'). #' @param xaxis.line The position of the x axis (the argument 'line'). #' @param legend.left How much left should the legend be from the matrix. #' @param legend.up How much up should the legend be from the matrix. #' @param legend.size Relative legend size. #' @param legend.text.hor.pos Horizontal position of the legend text (bottom) - 0 = bottom, 0.5 = middle,... #' @param par.line.width The width of the line that separates the partitions. #' @param par.line.width.newSet The width of the line that separates that separates the sets/modes - only used when \code{clu} is a list and \code{par.line.width} has length 1. #' @param par.line.col The color of the line that separates the partitions. #' @param par.line.col.newSet The color of the line that separates that separates the sets/modes - only used when \code{clu} is a list and \code{par.line.col} has length 1. #' @param IM.dens The density of shading lines in each block. #' @param IM The image (as obtained with \code{critFunC}) of the blockmodel. \code{dens.leg} is used to translate this image into \code{IM.dens}. #' @param wnet Specifies which matrix (if more) should be plotted - used if \code{M} is an array. #' @param 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. #' @param use.IM Specifies if \code{IM} should be used for plotting. #' @param dens.leg It is used to translate the \code{IM} into \code{IM.dens}. #' @param blackdens At which density should the values on dark colors of lines be printed in white. #' @param 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. #' @param frameMatrix Should the matrix be framed (if \code{plotLines} is \code{FALSE}). The default value is set to \code{TRUE}. #' @param x0ParLine Coordinates for lines separating clusters. #' @param x1ParLine Coordinates for lines separating clusters. #' @param y0ParLine Coordinates for lines separating clusters. #' @param y1ParLine Coordinates for lines separating clusters. #' @param colByUnits Coloring units. It should be a vector of unit length. #' @param colByRow Coloring units by rows. It should be a vector of unit length. #' @param colByCol Coloring units by columns. It should be a vector of unit length. #' @param mulCol Multiply color when joining with row, column. Only used when when \code{colByUnits} is not \code{NULL}. #' @param joinColOperator Function to join \code{colByRow} and \code{colByCol}. The default value is set to \code{"+"}. #' @param colTies If \code{TRUE}, ties are colored, if \code{FALSE}, 0-ties are colored. #' @param maxValPlot The value to use as a maximum when computing colors (ties with maximal positive value are plotted as black). #' @param printMultipliedMessage Should the message '* all values in cells were multiplied by' be printed on the plot. The default value is set to \code{TRUE}. #' @param replaceNAdiagWith0 If \code{replaceNAdiagWith0 = TRUE} Should the \code{NA} values on the diagonal of a matrix be replaced with 0s. #' @param title.row Title for the row-normalized matrix in nm version #' @param title.col Title for the column-normalized matrix in nm version #' @param par.set A list of possible plotting parameters (to \code{par}) to be used in nm version #' @param which Which (if there are more than one) of optimal solutions to plot. #' @param colLabels Should the labels of units be colored. If \code{FALSE}, these are not colored, if \code{TRUE}, they are colored with colors of clusters as defined by palette. #' This can be also a vector of colors (or integers) for one-mode networks or a list of two such vectors for two-mode networks. #' @param MplotValues A matrix to strings to plot in cells. Only to be used if other values than those in the original matrix (\code{x} or \code{M} arguments) should be used. Defaults to \code{NULL}, in which case the valued from original matrix are plotted (if this is not prevented by some other arguments). Overrides all other arguments that deal with cell values (e.g. \code{print.digits.cells}). Sets \code{print.val} to \code{TRUE} and \code{plot.legend} to \code{FALSE}. #' @param \dots Additional arguments to \code{plot.default} for \code{plotMat} and also to \code{plotMat} for other functions. #' #' @return 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}} #' @keywords graphs hplot #' #' @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" #' @import Matrix #' @import methods #' @importFrom grDevices gray #' @importFrom graphics mtext par plot.default rect segments text title #' #' @export plotMat <- function( x=M, #x should be a matrix or similar object clu=NULL, #partition orderClu=FALSE, #should the partition be ordered 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 possibly some other functions in the package 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 plotted 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 ignored, 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 plotted 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 coordinate of the x axis values y.axis.val.pos = -0.01, #x coordinate 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 separates the partitions par.line.width.newSet = par.line.width[1]*2, #the width of the line that separates the sets par.line.col = "blue", #the color of the line that separates the partitions par.line.col.newSet = "red", #the color of the line that separates the sets IM.dens= NULL, IM= NULL, #Image used for plotting (shaded lines) wnet=NULL, #which net (if more) should be plotted - used if M is an array wIM=NULL, #which IM (if more) should be used for plotting (default = wnet) - used if IM is an array use.IM=length(dim(IM))==length(dim(M))|!is.null(wIM), #should IM be used for plotting? 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, # should multiplication 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 colored, if TRUE, they are colored with colors of clusters as defined by palette. This can be also a vector of colors (or integers) for one-mode networks or a list of two such vectors for two-mode networks. MplotValues=NULL, #a matrix of strings to plot into cells. ... #aditional arguments to plot.default ){ old.mar<-par("mar") if(min(dim(M))==1 & is.null(wnet)) wnet<-1 if(orderClu) { clu<-orderClu(M, clu=clu) ord<-order(attr(clu,"reorder")) if(!is.null(IM))if(length(dim(IM))==2){ IM<-IM[ord,ord] } else if(length(dim(IM))==3){ IM<-IM[,ord,ord] } else 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") if(length(dim(IM))>length(dim(M))&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 } } }else{ plotArray(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 plotted 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 ignored, 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 plotted 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 squares in y direction val.x.coor.cor = val.x.coor.cor, #correction for centering the values in the squares 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 coordinate of the x axis values y.axis.val.pos = y.axis.val.pos, #x coordinate 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 separates the partitions par.line.width.newSet = par.line.width.newSet, #the width of the line that separates the sets par.line.col = par.line.col, #the color of the line that separates the partitions par.line.col.newSet = par.line.col.newSet, #the color of the line that separates the sets IM.dens= IM.dens, IM= IM, #Image used for plotting (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 plotting? 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] } newSetK<-0 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 newSetK<-cumsum(tmNclu[-length(tmNclu)]) } } 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]) #defining the positions of rectangles 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<-gray(1-aMnorm) #definin the color of rectangles }else col<-matrix(gray(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 if(!(plotLines)){ plotRect<-rep(TRUE,length(col)) if(is.integer(col)){ plotRect[col==0]<-FALSE }else{ plotRect[col=="white"]<-FALSE plotRect[col=="transparent"]<-FALSE plotRect[grep(pattern = "^#......00$",x=col)]<-FALSE } } 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[plotRect], ybottom=ybottom[plotRect], xright=xright[plotRect], ytop=ytop[plotRect], col=col[plotRect],cex.lab=cex.lab,border=if(plotLines)"black" else NA) }else{ rect(xleft=xleft[plotRect], ybottom=ybottom[plotRect], xright=xright[plotRect], ytop=ytop[plotRect], col=col[plotRect],cex.lab=cex.lab,density=dens[plotRect],border=if(plotLines)"black" else NA) } if(newSetK[1]!=0 && length(par.line.col)==1) { par.line.col<-rep(par.line.col, length(lines.row)) par.line.col[newSetK]<-par.line.col.newSet } if(newSetK[1]!=0 && length(par.line.width)==1){ par.line.width<-rep(par.line.width, length(lines.row)) par.line.width[newSetK]<-par.line.width.newSet } 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(length(lines.row)>0) segments(x0=x0ParLine,x1=x1ParLine,y0=lines.row,y1=lines.row,col=par.line.col,lwd=par.line.width) if(length(lines.col)>0) 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(!is.null(MplotValues)){ if(dim(MplotValues)==dim(M)&&is.character(MplotValues)){ plot.legend<-FALSE } else warning("MplotValues is ignored. It should be the same dimension as the main matrix (x or M) and be a character") } if(print.val|(!is.null(MplotValues))){ #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(MplotValues) 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) } #' @rdname plotMat #' #' @param main.title Main title in \code{plotArray} version. #' @param main.title.line The line in which main title is printed in \code{plotArray} version. #' @param mfrow \code{mfrow} Argument to \code{par} - number of row and column plots to be plotted on one figure. #' #' @export 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,x,0)blockmodeling/R/loadvector2.R0000644000176200001440000000134313677022067015646 0ustar liggesusers#' @rdname Pajek #' #' @description \code{loadvector2} - The same as above, but adapted to be called within \code{loadpajek} - as a consequence not suited for reading clusters. #' @importFrom utils read.table #' #' @export "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.R0000644000176200001440000000263013677022067014570 0ustar liggesusers#' @rdname REGE #' #' @export "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/critFunCinternalFunctions.R0000644000176200001440000001333614236472206020566 0ustar liggesuserscStatus<-list( blockTypes=c("nul", "com", "cdo", "rdo", "cfn", "rfn", "reg", "cre", "rre", "avg", "dnc"), regFuns=c("max","sum","mean"), homFuns=c("ss", "ad", "bll"), implementedApproaches=c("hom", "bin","val") # ,maxBlockTypes=as.integer(10) ) # zgornje spremenljivke morajo biti enake kot v C-ju (blockmodeling.c) allInDimEqual<-function(arr,d)all(apply(arr,d,function(x){x<-as.vector(x);all(x==x[1])})) clu2parArr<-function(clu){ if(!is.list(clu))clu<-list(clu,clu) nrc<-sapply(clu,length) clu<-lapply(clu,function(x)as.integer(as.factor(x))) nUnitsInRCclu<-lapply(clu,function(x)as.integer(table(x))) nRCclu<-sapply(nUnitsInRCclu,length) rowParArr<-matrix(as.integer(0),nrow=nrc[1],ncol=nRCclu[1]) for(i in clu[[1]]){ rowParArr[1:nUnitsInRCclu[[1]][i],i]<-as.integer(which(clu[[1]]==i)-1) } colParArr<-matrix(as.integer(0),nrow=nrc[2],ncol=nRCclu[2]) for(i in clu[[2]]){ colParArr[1:nUnitsInRCclu[[2]][i],i]<-as.integer(which(clu[[2]]==i)-1) } return(list(rowParArr=rowParArr,colParArr=colParArr,nUnitsInRCclu=nUnitsInRCclu, nRCclu=nRCclu, nrc=nrc)) } parArr2clu<-function(nUnitsRowClu, nUnitsColClu, rowParArr, colParArr, nColClus=NULL, nRowClus=NULL){ clu<-list(parArrOne2clu(nUnitsClu=nUnitsRowClu, parArr=rowParArr, nClus=nRowClus),parArrOne2clu(nUnitsClu=nUnitsColClu, parArr=colParArr, nClus=nColClus)) } parArrOne2clu<-function(nUnitsClu, parArr,nClus=NULL){ if(is.null(nClus)){ nClus<-dim(parArr)[2] } else { if(nClus!=dim(parArr)[2]) warning("Number of clusters and dimmension of the partition array do not match") } n<-sum(nUnitsClu) clu<-rep(NA,n) for(i in 1:nClus){ clu[parArr[(1:nUnitsClu[i]),i]+1]<-i } return(clu) } IMaddNames<-function(IM){ array(factor(IM+1,labels=cStatus$blockTypes,levels=1:length(cStatus$blockTypes)),dim=dim(IM)) } formatPreSpecM<-function(preSpecMorg,dB,blocks){ if(is.null(preSpecMorg)){ preSpecM <- array(as.double(NA),dim=dB) } else if (is.vector(preSpecMorg)){ if(length(preSpecMorg)==1){ preSpecM <- array(as.double(preSpecMorg),dim=dB) } else if(length(preSpecMorg)==dB[2]){ preSpecM <- array(as.double(NA),dim=dB) for(i in 1:dB[2]){ preSpecM[,i,,]<-as.double(preSpecMorg[i]) } } else if((dB[2]==1) & (length(preSpecMorg)==dB[1]) & allInDimEqual(blocks,1)){ preSpecM <- array(as.double(NA),dim=dB) for(i in 1:dB[1]){ preSpecM[i,,,]<-as.double(preSpecMorg[i]) } } else stop("'",deparse(substitute(preSpecMorg)),"' is a vector with unexpected length") } else if(is.array(preSpecMorg)){ preSpecM <- array(as.double(preSpecMorg),dim=dim(preSpecMorg)) if(any(dim(preSpecM)!=dB)){ stop("dimensions of '",deparse(substitute(preSpecMorg)),"' and 'blocks' do not match") } } return(preSpecM) } computeCombWeights<-function(combWeights, dB, blocks, relWeights, posWeights, blockTypeWeights){ if(!is.null(combWeights)){ if(all(dim(combWeights)==dB)){ combWeights<-array(as.double(combWeights),dim=dim(combWeights)) return(combWeights) } warning("Dimmensions of the combWeights does not match the dimmensions of blocks!\nIt will not be used!\nIf possible it will be computed using other weights!") } combWeights<-array(as.double(1),dim=dB) relWeights<-as.double(relWeights) if(length(relWeights)!=dB[2]){ if(length(relWeights)==1) relWeights<-rep(relWeights,dB[2]) else stop("To relWeights should have length equal to the number of relations!") } for(i in 1:dB[2]){ combWeights[,i,,]<-combWeights[,i,,]*relWeights[i] } if(all(dim(posWeights)!=dB[3:4])){ if(length(posWeights)==1) posWeights<-array(posWeights,dim=dB[3:4]) else stop("To posWeights should have the same dimensions as block image!") } posWeights<-array(as.double(posWeights), dim=dim(posWeights)) for(i in 1:dB[3]){ for(j in 1:dB[4]){ combWeights[,,i,j]<-combWeights[,,i,j]*posWeights[i,j] } } if(!(is.numeric(blockTypeWeights)&all(names(blockTypeWeights)%in%cStatus$blockTypes))) stop("blockTypeWeights must be a numeric named vector with names from: ", paste(cStatus$blockTypes, collapse=", ")) for(i in names(blockTypeWeights)){ tWhich <- blocks==i tWhich[is.na(tWhich)]<-FALSE combWeights[tWhich]<-blockTypeWeights[i]* combWeights[tWhich] } return(combWeights) } formatUsePreSpecM<-function(usePreSpecMorg,preSpecM,dB,blocks){ if(is.null(usePreSpecMorg)){ usePreSpecM<- !is.na(preSpecM) }else if(is.vector(usePreSpecMorg)){ if(length(usePreSpecMorg)==dB[2]){ usePreSpecM <- array(as.integer(NA),dim=dB) for(i in 1:dB[2]){ usePreSpecM[,i,,]<-as.integer(usePreSpecMorg[i]) } } else if((dB[2]==1) & (length(usePreSpecMorg)==dB[1]) & allInDimEqual(blocks,1)){ usePreSpecM <- array(as.integer(NA),dim=dB) for(i in 1:dB[1]){ usePreSpecM[i,,,]<-as.integer(usePreSpecMorg[i]) } } else stop("'",deparse(substitute(usePreSpecM)),"' is a vector with unexpected length") } else if(is.array(usePreSpecMorg)){ if(any(dim(usePreSpecMorg)!=dB)){ stop("dimensions of '",deparse(substitute(usePreSpecM)),"' and 'blocks' do not match") } usePreSpecM <- array(as.integer(usePreSpecMorg),dim=dim(usePreSpecMorg)) } return(usePreSpecM) } blockmodeling/R/parOKgroups.R0000644000176200001440000000031013677022067015667 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/nanRep.R0000644000176200001440000000065014026571226014640 0ustar liggesusers#' @encoding UTF-8 #' @title Replaces NaN values by the speficied values (0 by default) #' #' @param x A vector or similar where the NaNs are to be replaced. #' @param rep A value that should replace the NaNs (0 by default). #' @return x with NaNs replaced by rep. #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' #' @keywords manip #' @export nanRep<-function(x, rep=0){ x[is.nan(x)]<-rep return(x) }blockmodeling/R/reorderImage.R0000644000176200001440000000310213677022067016022 0ustar liggesusers#' @encoding UTF-8 #' @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) #' #' @param IM An image or error matrix. #' @param oldClu Old partition. #' @param newClu New partition, the same as the old one except for class labeles. #' #' @return 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}} #' @keywords manip #' #' @export reorderImage<-function(IM,oldClu,newClu){ if(crand2(oldClu,newClu)!=1)stop("Old and new clu's are not compatibale (crand index is not 1)!\n") newOrder<-which(table(oldClu,newClu)>0,arr.ind=TRUE)[,1] return(IM[newOrder,newOrder]) } blockmodeling/R/blockmodeling-package.R0000644000176200001440000001017214471135610017614 0ustar liggesusers#' @encoding UTF-8 #' @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. #' #' #' @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 #' #' @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 #' 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) #' err(res) # The error is relatively small #' IM(res) #' 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) #' err(res) # The error is relatively small #' IM(res) #' plot(res) #' #' #' # Optimizing a very bad partition #' cluStart <- rep(1:2, times = 10) #' res <- optParC(M = net, #' clu = cluStart, #' approaches = "hom", homFun = "ss", blocks = "com") #' clu(res) # Hopefully we get the original partition) #' err(res) #' plot(res) #' #' # Optimizing 10 random chosen partitions with optRandomParC #' res <- optRandomParC(M = net, k = 2, rep = 10, #' approaches = "hom", homFun = "ss", blocks = "com") #' clu(res) # Hopefully we get the original partition) #' err(res) #' plot(res) #' #' # 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) #' err(res) # The error is relatively small #' IM(res) #' # The image corresponds to the one used for generation of #' # The network #' plot(res) #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' @seealso \code{\link{optRandomParC}}, \code{\link{critFunC}}, \code{\link{optParC}}, \code{\link{IM}}, \code{\link{clu}}, \code{\link{err}}, \code{\link{plotMat}} #' @keywords cluster graphs package #' @docType package #' @name blockmodeling #' @aliases blockmodeling-package #' @useDynLib blockmodeling, .registration = TRUE NULLblockmodeling/R/plot.mat.nm.R0000644000176200001440000000256314077470122015570 0ustar liggesusers#' @importFrom graphics mtext par plot.default rect segments text title #' @rdname plotMat #' #' @param main.title Main title in \code{plotMatNm} version. #' @param title.row Title for row normalized version in \code{plotMatNm}. #' @param title.col Title for column normalized version in \code{plotMatNm}. #' @param title.col Title for column normalized version in \code{plotMatNm}. #' @param main.title.line Used instead of \code{title.line} in \code{plotMatNm}. #' @param par.set Used instead of \code{title.line} in \code{plotMatNm}. #' #' @export plotMatNm <- function(M=x,x=M,...,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.R0000644000176200001440000000636014257652004015771 0ustar liggesusers#' @rdname Pajek #' #' @description \code{savenetwork} - Saves a matrix into a Pajek ".net" filename. #' #' @param n A matrix representing the network. #' @param 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. #' @param symetric If \code{TRUE}, only the lower part of the matrix is used and the values are interpreted as "Edges", not "Arcs". #' @import Matrix #' @importFrom utils write.table #' #' @export "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(inherits(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.R0000644000176200001440000000342614216546204017520 0ustar liggesusers#' @rdname funByBlocks #' @export "funByBlocks.default" <- function(x = M, clu, M = x, ignore.diag = "default", sortNames = TRUE, FUN = "mean", ...) { M<-as.array(M) dM<-dim(M) nn<-ifelse(length(dM)==2,1,dM[3]) 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,3,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.R0000644000176200001440000001116113677022067016034 0ustar liggesusers#' @rdname Pajek #' #' @description \code{loadnetwork2} - The same as above, but adapted to be called within \code{loadpajek}. #' #' @param safe If \code{FALSE} error will occur if not all vertices have labels. If \code{TRUE} reading works faster. #' @param closeFile Should the connection be closed at the end. Should be always \code{TRUE} if function is used directly. #' @import Matrix #' @importFrom utils read.table #' #' @export "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.R0000644000176200001440000000123713716705123016720 0ustar liggesusers#' @rdname plotMat #' @export "plot.optMorePar" <- function( x,#an "optParMode" 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=IM(x,which=which),main=main,...) } #' @rdname plotMat #' @method plot opt.more.par #' @export plot.opt.more.par<-plot.optMoreParblockmodeling/R/plot.opt.more.par.mode.R0000644000176200001440000000125713717144501017643 0ustar liggesusers#' @rdname plotMat #' @export "plot.optMoreParMode" <- function( x,#an "optParMode" 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=IM(x,which=which),main=main,...) } #' @rdname plotMat #' @method plot opt.more.par.mode #' @export plot.opt.more.par.mode<-plot.optMoreParModeblockmodeling/R/genMatrixMult.r0000644000176200001440000000263113677022067016263 0ustar liggesusers#' Generalized matrix multiplication #' #' 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) #' #' @param A The first matrix. #' @param B The second matrix. #' @param FUNelement Element-wise operator. #' @param FUNsummary Summary function. #' #' @return A character vector or matrix. #' #' @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) #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' @seealso \code{\link{matmult}} #' @keywords array algebra #' #' @export genMatrixMult<-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.R0000644000176200001440000000555313677022067017206 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/data.R0000644000176200001440000000127113677022067014333 0ustar liggesusers#' Citation data between social work journals for the 1985-86 period #' #' This example consists of the citation data between social #' work journals for the 1985-86 period, collected and analyzed #' in Baker (1992) #' #' @docType data #' #' @usage data(baker) #' #' #' @keywords datasets #' #' @references #' \enc{Baker, D. R.}{Baker, D. R.} (1992). A Structural Analysis of Social Work Journal Network: 1985-1986. Journal of Social Service Research, 15(3-4), 153-168. doi: 10.1300/J079v15n03_09 #' #' #' @examples #' # data(baker) #' # Transforming it to matrix format #' # baker <- as.matrix(baker) #' # putting zeros on the diagonal #' # diag(baker) <- 0 "baker" blockmodeling/R/loadpajek.R0000644000176200001440000000537513677022067015365 0ustar liggesusers#' @rdname Pajek #' #' @description \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. #' #' @export loadpajek<-function(filename){ if(is.character(filename)) {file<-file(description=filename,open="r") }else file<-filename res<-list(Networks=list(),Partitions=list(),Vectors=list(),Permutation=list()) nblanklines=0 while(TRUE){ line<-scan(file = file, nlines =1,what="char",quiet =TRUE, 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.R0000644000176200001440000000226613677022067015141 0ustar liggesusers#' @rdname find.m #' #' @export "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 critFun ){ 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.R0000644000176200001440000000066013677022067015020 0ustar liggesusers#' @rdname two2one #' #' @export "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/printBlocks.R0000644000176200001440000000223314306071413015700 0ustar liggesusers#' @encoding UTF-8 #' @title Nice printing of the \code{blocks} parameter as used in \code{\link{optRandomParC}} and \code{\link{critFunC}}. #' #' @param blocks \code{blocks} parameter as used in \code{\link{optRandomParC}} and \code{\link{critFunC}}. #' #' #' @return #' Used for side effects (printing) #' @author \enc{Aleš, Žiberna}{Ales Ziberna} #' @seealso \code{\link{optRandomParC}}, \code{\link{critFunC}} #' @keywords print #' #' @export printBlocks<-function(blocks){ B<-blocks if(is.vector(B)){ if(is.list(B)){ for(i in 1:length(B)){ cat("Relation ",i,":", sep="") cat(B[[i]]) } } else cat(B,"\n") } else{ if(length(dim(B))==2){ print(data.frame(B,check.names = FALSE)) } else if(length(dim(B))==3){ print(data.frame(apply(B,2:3,function(x)paste(na.omit(x),collapse=",")),check.names = FALSE)) } else if(length(dim(B))==4){ if(dim(B)[2]==1){ printBlocks(B[,1,,]) } else for(i in 1:dim(B)[2]){ cat("Relation",i,"\n") print(data.frame(apply(B[,i,,],2:3,function(x)paste(na.omit(x),collapse=",")),check.names = FALSE)) } } } }blockmodeling/R/funByBlocks.R0000644000176200001440000000571414216546401015642 0ustar liggesusers#' Computation of function values by blocks #' #' Computes a value of a function over blocks of a matrix, defined by a partition. #' #' @param x An object of suitable class or a matrix/array 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 (different kinds of units with no ties among themselves. #' If the network is not two-mode, the matrix must be square. #' @param 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. #' @param 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 (different kinds of units with no ties among themselves. #' If the network is not two-mode, the matrix must be square. #' @param ignore.diag Should the diagonal be ignored. #' @param sortNames Should the rows and columns of the matrix be sorted based on their names. #' @param FUN The function to be computed over the blocks. #' @param which Which (if several) of the "best" solutions should be used. #' @param \dots Further arguments to \code{funByBlocks.default}. #' #' @return 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 #' funByBlocks(res) #' # Computing mean by blocks, ignoring the diagonal (default) #' #' @keywords cluster math #' #' @export funByBlocks <- function(x, ...) UseMethod("funByBlocks") #' @rdname funByBlocks #' @export fun.by.blocks<-funByBlocksblockmodeling/R/plot.opt.par.mode.R0000644000176200001440000000123513717144511016677 0ustar liggesusers#' @rdname plotMat #' @export "plot.optParMode" <- function( x,#an "optParMode" 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=IM(x,which=which),main=main,...) } #' @rdname plotMat #' @method plot opt.par.mode #' @export plot.opt.par.mode<-plot.optParModeblockmodeling/R/find.m.R0000644000176200001440000001612713677022067014603 0ustar liggesusers#' @encoding UTF-8 #' @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", ...) #' #' @param 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. #' @param 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. #' @param 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). #' @param diag (default = \code{TRUE}) Should the special status of diagonal be acknowledged. #' @param 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}). #' @param FUN (default = "max") Function f used in row-f-regular, column-f-regular, and f-regular blocks. #' @param cuts The cuts, which should be evaluated. If \code{cuts="all"} (default), all unique values are evaluated. #' @param neval A number of different \code{m} values to be evaluated. #' @param half Should the returned value of m be one half of the value where the inconsistencies are the same. #' @param ms The values of m where the function should be evaluated. #' @param \dots Other parameters to \code{critFunC}. #' #' @return 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}} #' #' @keywords cluster #' @importFrom stats optimize #' @export "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.R0000644000176200001440000000034013677022067015157 0ustar liggesusers#' @importFrom utils citation .onAttach<-function(libname, pkgname){ requireNamespace("utils") cit<-citation(pkgname) txt<-paste(c(format(cit,"citation")),collapse="\n\n") packageStartupMessage(txt) }blockmodeling/R/meanpos.R0000644000176200001440000000005313677022067015061 0ustar liggesusers"meanpos" <- function(v){mean(v[v>0])} blockmodeling/R/formatA.R0000644000176200001440000000157713677022067015024 0ustar liggesusers#' @encoding UTF-8 #' @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, ...) #' #' @param x A numerical vector or matrix. #' @param digits The number of desired digits. #' @param FUN Function used for "shortening" the numbers. #' @param \dots Additional arguments to \code{format}. #' #' @return A character vector or matrix. #' #' @examples #' A <- matrix(c(1, 1.02002, 0.2, 10.3), ncol = 2) #' formatA(A) #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' @seealso \code{\link{find.m}}, \code{\link{find.m2}}, \code{\link{find.cut}} #' @keywords character #' #' @export "formatA" <- function(x,digits=2, FUN=round,...){ noquote(format(FUN(x, digits=digits),...)) } blockmodeling/R/plot.check.these.par.R0000644000176200001440000000106213716720712017336 0ustar liggesusers#' @export "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=clu(x,which=which),IM=IM(x,which=which),main=main,...) } blockmodeling/R/notesBorrowing.R0000644000176200001440000000241613677022067016445 0ustar liggesusers#' @encoding UTF-8 #' @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). #' #' @format The data set is a valued matrix with 13 rows and columns. #' #' @usage data("notesBorrowing") #' #' @examples #' data(notesBorrowing) #' #' # Plot the network. #' # (The function plotMat is from blockmodeling package.) #' # plotMat(nyt) #' #' @keywords datasets #' #' @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 #' #' @docType data #' @name notesBorrowing NULLblockmodeling/R/fun.by.blocks.opt.more.par.R0000644000176200001440000000212314077544463020423 0ustar liggesusers#' @rdname funByBlocks #' @param orderClu Should the partition be ordered before computing. \code{FALSE} by default. If \code{TRUE}, \code{\link{orderClu}} is used (using default arguments) to order the clusters in a partition in "decearsing" (see \code{\link{orderClu}} for interpretation) order. If \code{TRUE}, \code{sortNames} is set to \code{FALSE}. #' @export "funByBlocks.optMorePar" <- function( x, #an object of class "optMorePar" which=1, #which best solution/partition should be used orderClu=FALSE, #should the partition be ordered. sortNames = NULL, ... #aditional parameters to function "funByBlocks" ){ if(which>length(x$best)){ which<-1 warning("Only",length(x$best),"solutions exists. The first solution will be used.") } tclu<-clu(x,which=which) if(orderClu) { tclu<-orderClu(x=x$M, clu=tclu) if(is.null(sortNames))sortNames<-FALSE } else if(is.null(sortNames))sortNames<-TRUE funByBlocks(M=x$M, clu=tclu,...) } #' @rdname funByBlocks #' @method funByBlocks opt.more.par #' @export funByBlocks.opt.more.par<-funByBlocks.optMorePar blockmodeling/R/splitClu.R0000644000176200001440000000453314270174176015224 0ustar liggesusers#' @encoding UTF-8 #' @title Functions creating a list of partitions based on a single partition and information on the number of units in each set. #' #' @description #' Function \code{splitClu} creates a list of partitions based on a single partition (\code{clu}) and information on the number of units in each set (\code{n}). #' #' Function \code{splitCluRes} does the same but extracts the information from the result of (old versions of) functions \code{\link{critFunC}}, \code{\link{optParC}}, \code{\link{optRandomParC}} or similar (newer versions should already return a list of partitions in case they are used on networks with more sets of units. #' #' @param clu A vector representing a partition of units from different sets. Result of some legacy code for \code{\link{optRandomParC}} or \code{\link{optParC}} or similar functions. #' @param n A vector with number of units per set. The assuption is that the first \code{n[1]} elements of \code{clu} are for the first set, the second \code{n[2]} elements of \code{clu} are for the second set and so on. \code{sum(n)} must be equal to \code{length(clu)}. #' @param res Result of (old versions of) functions \code{\link{critFunC}}, \code{\link{optParC}}, \code{\link{optRandomParC}} or similar. #' @param renumber If \code{TRUE}, elements of each partition (for each set) in the list are renumbered to be from 1:"number of clusters" in that partition). Defaults to \code{FALSE}. #' #' #' @return A list of partitions if \code{clu}, one for each set of units. A single vector if only one set of units is present. #' #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' #' #' @seealso \code{\link{clu}}, \code{\link{unlistClu}}, \code{\link{unlistCluInt}} #' #' #' @examples #' n <- c(8,8) #' clu <- c(rep(1:2, times = c(3, 5)), rep(3:4, times = c(3, 5))) #' splitClu(clu = clu, n = n ) #' splitClu(clu = clu, n = n, renumber = TRUE) #' #' @keywords manip #' @export splitClu<-function(clu, n, renumber=FALSE){ if(length(n)==1) return(clu) clu<-split(clu, rep(1:length(n),times=n)) if(renumber){ return(lapply(clu, function(x)as.integer(factor(x)))) }else return(clu) } #' @rdname splitClu #' #' @export splitCluRes<-function(res, renumber=FALSE){ clu<-clu(res) n<-res$initial.param$n if(is.list(clu)) return(clu) splitClu(clu,n,renumber=renumber) } blockmodeling/R/savevector.R0000644000176200001440000000065213677022067015605 0ustar liggesusers#' @rdname Pajek #' #' @description \code{savevector} - Saves a vector into a Pajek ".clu" filename. #' #' @param v A vector. #' #' @export "savevector" <- structure(function(v,filename){ if(length(grep(pattern="w32",x=version["os"]))){ eol<-"\n" }else{eol<-"\r\n"} cat(paste(c(paste("*Vertices",length(v)), v),collapse=eol),file = filename) } , comment = "Save vector to file that can be read by Pajek") blockmodeling/R/REGE.FC.ow.R0000644000176200001440000000443113677022067015060 0ustar liggesusers#' @rdname REGE #' #' @export "REGE.FC.ow" <- function(M,E=1,iter=3,until.change=TRUE,use.diag=TRUE,normE=FALSE){ n<-dim(M)[1] if(n!=dim(M)[2]) stop("M must be a 1-mode matrix") if(length(dim(M))==2)M<-array(M,dim=c(n,n,1)) nr<-dim(M)[3] if(!use.diag){for(ir in 1:nr) diag(M[,,ir])<-0} Eall<-array(NA,dim=c(n,n,iter+1)) #An array of 'iter' similiaritie matrices Eall[,,1]<-E diag(Eall[,,1])<-1 for(it in 1:iter){ for(i in 2:n){ for(j in 1:(i-1)){ num<-0 den<-0 for(ir in 1:nr){ for(k in 1:n){ if(M[i,k,ir]>0) { mins<-Eall[k,,it]*pmin(M[i,k,ir],M[j,,ir]) num<-num+max(mins) den<-den+min(pmax(M[i,k,ir],M[j,which(mins==max(mins)),ir])) #cat("M[i,k]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n") } if(M[k,i,ir]>0) { mins<-Eall[k,,it]*pmin(M[k,i,ir],M[,j,ir]) num<-num+max(mins) den<-den+min(pmax(M[k,i,ir],M[which(mins==max(mins)),j,ir])) #cat("M[k,i]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n") } if(M[j,k,ir]>0) { mins<-Eall[k,,it]*pmin(M[j,k,ir],M[i,,ir]) num<-num+max(mins) den<-den+min(pmax(M[j,k,ir],M[i,which(mins==max(mins)),ir])) #cat("M[j,k]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n") } if(M[k,j,ir]>0) { mins<-Eall[k,,it]*pmin(M[k,j,ir],M[,i,ir]) num<-num+max(mins) den<-den+min(pmax(M[k,j,ir],M[which(mins==max(mins)),i,ir])) #cat("M[k,j]: ","i = ",i, ", j = ",j,", k = ",k,", num = ", num, ", den = ", den,"\n") } } } if(den!=0) { Eall[j,i,it+1]<-Eall[i,j,it+1]<-num/den } else Eall[j,i,it+1]<-Eall[i,j,it+1]<-1 diag(Eall[,,it+1])<-1 } } if(normE){ diag(Eall[,,it+1])<-0 Eall[,,it+1]<-Eall[,,it+1]/sqrt(outer(apply(Eall[,,it+1],1,sum), apply(Eall[,,it+1],2,sum))) diag(Eall[,,it+1])<-max(Eall[,,it+1]) } if(until.change & all(Eall[,,it]==Eall[,,it+1])){ Eall<-Eall[,,1:(it+1)] break } } itnames<-0:(it) itnames[1]<-"initial" itnames[it+1]<-"final" dimnames(Eall)<-list(dimnames(M)[[1]],dimnames(M)[[2]],itnames) return(list(E=Eall[,,"final"],Eall=Eall,M=M,iter=iter,use.diag=use.diag)) } blockmodeling/R/loadnetwork4.R0000644000176200001440000000743213677022067016044 0ustar liggesusers#' @rdname Pajek #' #' @description \code{loadnetwork4} - Another version for reading networks. #' #' @param fill If \code{TRUE}, then in case the rows have unequal length, blank fields are added. #' @import Matrix #' @importFrom utils read.table #' #' @export "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.R0000644000176200001440000000144614026571127014046 0ustar liggesusers#' @encoding UTF-8 #' @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. \code{ssNa} removes missing values (\code{NA}s) before calling the \code{ss} function. #' #' @param x A numeric vector. #' #' @return Sum of Squared deviations from the mean or sum of Absolute Deviations from the median. #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' @keywords univar #' @importFrom stats median #' #' @export "ss" <- function(x){sum(x^2)-sum(x)^2/length(x)} #' @rdname ss #' #' @export ssNa<-function(x)ss(na.omit(as.vector(x))) #' @rdname ss #' #' @export "ad" <- function(x)sum(abs(x-median(x))) blockmodeling/R/optRandomParC.R0000644000176200001440000005701314257651634016143 0ustar liggesusers#' @encoding UTF-8 #' @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). #' The number of clusters and a number of partitions to generate can be specified (\code{optParC}). #' #' @param k The number of clusters used in the generation of partitions. #' @param rep The number of repetitions/different starting partitions to check. #' @param save.initial.param.opt Should the inital parameters(\code{approaches}, ...) of using \code{optParC} be saved. The default value is \code{FALSE}. #' @param deleteMs Delete networks/matrices from the results of to save space. #' @param 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). #' @param switch.names Should partitions that only differ in group names be considered equal. By default it is set to \code{TRUE} if \code{blocks} is either a vector or a list of vectors and to \code{FALSE} otherwise. #' @param return.all If \code{FALSE}, solution for only the best (one or more) partition/s is/are returned. #' @param return.err Should the error for each optimized partition be returned. #' @param seed Optional. The seed for random generation of partitions. #' @param RandomSeed Optional. Integer vector, containing the random number generator. It is only looked for in the user's workspace. #' @param 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). #' @param mingr Minimal allowed group size. #' @param maxgr Maximal allowed group size. #' @param addParam A list of additional parameters for function specified above. In the usage section they are specified for the default function \code{\link{genRandomPar}}. #' @param 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}. #' @param skip.par The partitions that are not allowed or were already checked and should therefore be skipped. #' @param useOptParMultiC For backward compatibility. May be removed soon. See next argument. #' @param 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. #' @param printRep Should some information about each optimization be printed. #' @param 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). #' @param nCores Number of cores to be used. Value \code{0} means all available cores. It can also be a cluster object. #' @param useParLapply Should \code{parLapplyLB} or \code{parLapply} (see \code{useLB}) be used for parallel execution (on multiple cores). Otherwise \code{mforeach} is used. Defaults to FALSE. If \code{useParLapply = TRUE} and \code{useLB = TRUE}, results are not reproducible. #' @param useLB Should be logical if set. Only used if \code{useParLapply = TRUE}. Should load balancing be used (\code{parLapplyLB} instead of \code{parLapply}). Using load balancing usually means faster execution, but results are with not reproducible. Defaults to \code{NULL}, which is changed to \code{TRUE}, but a warning. #' @param chunk.size chunk.size used in \code{parLapplyLB} if it is used, otherwise ignored. Defaults to 1. #' @param cl The cluster to use (if formed beforehand). Defaults to \code{NULL}. Ignored if useParLapply=FALSE (default) and foreach::getDoParRegistered is true #' @param stopcl Should the cluster be stoped after the function finishes. Defaults to \code{is.null(cl)}. #' @param useRegParrallaBackend Should the function use already registered parallel backend. Defaults to \code{FALSE}. If \code{TRUE}, you must make sure that an appropriate backend is correctly set up and registered. Use only if \code{useParLapply = FALSE} (default) and \code{nCore} is not 1. #' @param genPajekPar Should the partitions be generated as in Pajek. #' @param 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}. #' @param \dots Arguments passed to other functions, see \code{\link{critFunC}}. #' @inheritParams critFunC #' #' @return #' \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{optParC}, 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 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}}, \code{\link{IM}}, \code{\link{clu}}, \code{\link{err}}, \code{\link{plot.optMorePar}} #' #' @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 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 #' #' @keywords cluster graphs #' @import methods #' @import parallel #' @importFrom stats na.omit runif #' #' @export "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 critFun 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 useParLapply = FALSE, # Should parLapplyLB be used (otherwise foreach is used) useLB = NULL, # Should load balancing be used (parLapplyLB instead of parLapply) chunk.size = 1, #chunk.size used in parLapplyLB if it is used, otherwise ignored. cl = NULL, #the cluster to use (if formed beforehand) stopcl = is.null(cl), # should the cluster be stopped useRegParrallaBackend = FALSE, #should the function use already registered parallel backend. Defaults to FALSE. If TRUE, you must make sure that an appropriate backend is correctly set up and registered. ... #parameters to optParC ){ dots<-list(...) #this might not be need - can be removed and all latter occurrences given sufficient testing. Left for now as there is not enough time. if(is.null(switch.names)){ if(is.list(blocks)){ switch.names<-all(sapply(blocks,is.vector)) } else switch.names<-is.vector(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) if(exists(".Random.seed")) .Random.seed-> RandomSeed } on.exit({ whichMin<-which(err==min(err, na.rm = TRUE)) res1 <- res[whichMin] 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(whichMin)," solutions (some may be duplicated) 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) if(exists(".Random.seed")){ Random.seed<-.Random.seed if(identical(Random.seed,RandomSeed)) Random.seed<-NULL } else Random.seed<-NULL 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)<-"optMorePar" return(res) }) if(!is.null(cl)) nCores<-0 if(nCores==1||!requireNamespace("parallel")){ if(nCores!=1) { oldWarn<-options("warn") options(warn=1) warning("Only single core is used as package 'parallel' is not available") options(warn=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 { oneRep<-function(i,M,approaches, blocks, n,k,mingr,maxgr,addParam,rep,...){ 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(inherits(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)) } if(useParLapply||!requireNamespace("doParallel")||!requireNamespace("foreach")||!requireNamespace("doRNG")) useParLapply<-TRUE if(nCores==0){ nCores<-detectCores()-1 } pkgName<-utils::packageName() if(is.null(pkgName)) { pkgName<-utils::packageName(environment(optParC)) cat("Package name set by a trick!\n") } if(useParLapply) { if(is.null(cl)) { if(Sys.info()['sysname']=="Windows"){ cl <- makeCluster(nCores) } else { cl <- makeForkCluster(nCores) } } clusterSetRNGStream(cl) #clusterExport(cl, varlist = c("kmBlock","kmBlockORP")) #clusterExport(cl, varlist = "kmBlock") clusterExport(cl, varlist = "pkgName", envir=environment()) clusterEvalQ(cl, expr={require(pkgName,character.only = TRUE)}) if(is.null(useLB)) { useLB<-TRUE warning("useLB not set and now set to TRUE. parLapplyLB will be used. Results will not be reproducible.") } if(useLB){ res<-parLapplyLB(cl = cl,1:rep, fun = oneRep, M=M, approaches=approaches, blocks=blocks, n=n, k=k, mingr=mingr, maxgr=maxgr, addParam=addParam, rep=rep, chunk.size=chunk.size, ...) } else{ res<-parLapply(cl = cl, 1:rep, fun = oneRep, M=M, approaches=approaches, blocks=blocks, n=n, k=k, mingr=mingr, maxgr=maxgr, addParam=addParam, rep=rep,...) } if(stopcl) stopCluster(cl) res<-lapply(res,function(x)x[[1]]) err<-sapply(res,function(x)x$err) nIter<-sapply(res,function(x)x$resC$nIter) } else { requireNamespace("doParallel") requireNamespace("doRNG") requireNamespace("foreach") `%dorng%`<-doRNG::`%dorng%` `%dopar%`<-foreach::`%dopar%` if(useRegParrallaBackend & (!foreach::getDoParRegistered())) { useRegParrallaBackend<-FALSE warning("No parallel backend is registred, seting useRegParrallaBackend to FALSE!") } if(!useRegParrallaBackend){ if(is.null(cl)) { if(Sys.info()['sysname']=="Windows"){ cl <- makeCluster(nCores) } else { cl <- makeForkCluster(nCores) } } doParallel::registerDoParallel(cl) } 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,...) err<-sapply(res,function(x)x$err) nIter<-sapply(res,function(x)x$resC$nIter) if(stopcl) { stopCluster(cl) foreach::registerDoSEQ() } } } } 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/loadnetwork3.R0000644000176200001440000000735113677022067016043 0ustar liggesusers#' @rdname Pajek #' #' @description \code{loadnetwork3} - Another version for reading networks. #' @import Matrix #' @importFrom utils read.table #' #' @export "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.R0000644000176200001440000000005113677022067014743 0ustar liggesusers"sumpos" <- function(v){sum(v[v>0])} blockmodeling/R/printRes.R0000644000176200001440000000316014205632633015221 0ustar liggesusers#' @rdname optRandomParC #' @param x The result of \code{\link{optRandomParC}}. #' @method print optMorePar #' @export "print.optMorePar" <- function(x,...){ rclu<-clu(x) if(is.list(rclu)){ n<-sapply(rclu,length) k<-sapply(rclu,function(x)length(unique(x))) } else{ n<-length(rclu) k<-length(unique(rclu)) } cat("Network size:",sum(n),"\n") if(length(n)>1) cat("Network size by sets:",n,"\n") if(!is.null(x$initial.param$approaches)){ cat("\nApproachs (paramter): ") if(!is.null(x$initial.param$dots.homFun)){ cat(paste(x$initial.param$approaches, x$initial.param$dots.homFun, sep = "-"),sep = ", ") } else cat(x$initial.param$approaches,sep = ", ") } if(!is.null(x$initial.param$blocks)){ cat("\nBlocks (paramter)\n") printBlocks(x$initial.param$blocks) haveBlocks<-TRUE } else haveBlocks<-FALSE cat("\nSizes of clusters:") if(length(n)==1) { print(table(clu(x))) }else{ for(i in 1:length(n)){ cat("Set",i,"\n") print(table(clu(x)[[i]])) } } rIM<-IM(x) if(haveBlocks){ printIM<-length(x$initial.param$blocks)>1 }else{ printIM<-!all(rIM==rIM[1]) } if(printIM){ cat("\nIM\n") if(length(dim(rIM))>2){ for(i in 1:dim(rIM)[1]){ cat("Relation ",i,"\n") print(data.frame(rIM[i,,],check.names = FALSE)) } } else print(data.frame(rIM,check.names = FALSE)) } cat("\nError:",min(x$err),"\n") if(length(x$best)>1) cat(length(x$best),"solutions with minimal error exits. Only results for the first one are shown above!\n") }blockmodeling/R/unlistCluInt.R0000644000176200001440000000263514270174214016054 0ustar liggesusers#' @encoding UTF-8 #' @title Unlist a partition. #' #' @description #' It is used to convert a partition by sets into a single "simple" partition. Simple partition is a partition of only one set, that is a vector where units with the same value are considered to belong to the same cluster. The partitions by sets is a list, where each element of a list is a "simple" partition that corresponds to one set. The function first converts all elements of the lists to integers, that makes sure that each set uses different integers and on the end uses unlist function on such list. #' #' @param clu A partition by sets, that is a list of "simple" partitions. #' @return The unlisted partition - one vector containing only integers. #' @seealso \code{\link{clu}}, \code{\link{splitClu}}, \code{\link{unlistClu}} #' @examples #' cluList<-list(c("a","b","a"),c("b","c","b","c")) #' unlistCluInt(cluList) #' #' cluList<-list(c(1,1,1,2,2,2),c(1,1,1,2,2,2,3,3)) #' unlistCluInt(cluList) #' @export unlistCluInt<-function(clu){ if(!is.list(clu)){ warning("Clu must be a list! The orginal argument is returned") } else { clu<-lapply(clu,function(x)as.integer(as.factor(x))) nUnitsInRCclu<-lapply(clu,function(x)as.integer(table(x))) tmNclu<-sapply(clu,max) for(iMode in 2:length(clu)){ clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) } clu<-unlist(clu) } return(clu) }blockmodeling/R/clu.R0000644000176200001440000000754614257651605014221 0ustar liggesusers#' @encoding UTF-8 #' @title Function for extraction of some elements for objects, returend by functions for Generalized blockmodeling #' #' @description #' Functions for extraction of partition (\code{clu}), all best partitions (\code{partitions}), #' image or blockmodel (\code{IM})) and total error or inconsistency (\code{err}) for objects, #' returned by functions \code{\link{critFunC}} or \code{\link{optRandomParC}}. #' # #' @usage clu(res, which = 1, ...) # #' partitions(res) # #' IM(res, which = 1, drop=TRUE, ...) # #' EM(res, which = 1, drop=TRUE, ...) # #' err(res, ...) partitions(res)#' #' #' @param res Result of function \code{\link{critFunC}} or \code{\link{optRandomParC}}. #' @param 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. #' @param drop If \code{TRUE} (default), dimensions that have only one level are dropped #' (\code{drop} function is applied to the final result). #' @param \dots Not used. #' #' #' @return 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. #' #' #' @keywords manip #' #' @export "clu" <- function(res,which=1,...){ if("clu" %in% names(res)){ res$clu }else res$best[[which]]$clu } #' @rdname clu #' #' @export "partitions" <- function(res)lapply(res$best,function(x)x$clu) #' @rdname clu #' #' @export "err" <- function(res,...){ if(is.null(res$best[[1]]$err)){ min(res$err) }else res$best[[1]]$err } #' @rdname clu #' #' @export "IM" <- function(res,which=1, drop=TRUE, ...){ if(inherits(res,c("optMorePar","opt.more.par"))){ IM<-res$best[[which]]$IM } else IM<-res$IM if(drop)IM<-drop(IM) return(IM) } #' @rdname clu #' #' @export "EM" <- function(res,which=1, drop=TRUE,...){ if(inherits(res,c("optMorePar","opt.more.par"))){ EM<-res$best[[which]]$EM } else EM<-res$EM if(drop)EM<-drop(EM) return(EM) } blockmodeling/R/savematrix.R0000644000176200001440000000404713677022067015611 0ustar liggesusers#' @rdname Pajek #' #' @description \code{savematrix} - Saves a matrix into a Pajek ".mat" filename. #' #' @importFrom utils write.table #' #' @export "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/orderClu.R0000644000176200001440000000735414257651721015211 0ustar liggesusers#' @encoding UTF-8 #' @title Orders the partition so that mean values of \code{fun} applied to columns (if \code{funWay=2}, default), rows (if \code{funWay=1}) or both (if \code{funWay=c(1,2)}) is decreasing by clusters. #' #' @description #' Orders the partition so that mean values of \code{fun} applied to columns (if \code{funWay=2}, default), rows (if \code{funWay=1}) or both (if \code{funWay=c(1,2)}) is decreasing by clusters. The function can be used on the results of \code{\link{critFunC}}, \code{\link{optRandomParC}} or similar, or matrix and a partition can be supplied. It should also work on multirelational and lined networks. #' #' @param x A result of \code{\link{critFunC}}, \code{\link{optRandomParC}} or similar (something containing M (matrix) and clu (partition)) or a matrix (or array for multirelational networks). #' @param clu A partition - a vector or a list of vectors/partitions. It must be supplied only if \code{x} is a matrix or array. #' @param fun A function used to summarize rows or columns. \code{sum} by default. #' @param funWay In which "way" should \code{fun} be appluied - to columns (if \code{funWay=2}, default), rows (if \code{funWay=1}) or both (if \code{funWay=c(1,2)}) #' @param nn The numbers of untis by sets of units. In principle, the function should determin this automatically. #' @param returnList Logical. Should the partition be returned in form of a list (for lined networks only). \code{TRUE} by default. #' @param scale Only used in case of multirelational networks. Should relations be scaled (\code{TRUE} by default) before summation. It can also be a vector of weights by relations. #' @return An ordered partition. In an attribute ("reorder"). the information on how things were reordered. #' @seealso \code{\link{clu}} #' @export orderClu<-function(x, clu=NULL, fun=sum, funWay=2, nn=NULL, returnList=TRUE, scale=TRUE){ if(inherits(x,c("check.these.par", "crit.fun", "critFun", "opt.more.par", "opt.more.par.mode", "opt.par", "opt.par.mode", "optMorePar", "optMoreParMode", "optPar", "optParMode"))){ tclu<- clu(x) M<-x$M if(is.null(nn))nn<-x$initial.param$initial.param$n } else{ M<-x if(is.null(clu)) stop("If x does not contain partition (clu), this must be supplied!") tclu<-clu } if(is.null(nn)&is.list(clu))nn<-sapply(clu,length) if(length(dim(M))>2){ if(isFALSE(scale)){ #do nothing }else if(isTRUE(scale)){ myScale<-function(x)(x-mean(x))/stats::sd(x) for(i in 1:dim(M)[3])M[,,i]<-myScale(M[,,i]) } else if(length(scale)==dim(M)[3]){ for(i in 1:dim(M)[3])M[,,i]<-scale[i]*(M[,,i]) } M<-apply(M,1:2, sum) } if(!is.null(nn)){ rAll<-NULL m<-length(nn) tclu<- by(tclu, INDICES = rep(1:m, times=nn), FUN=c) k<-sapply(tclu,function(x)length(unique(x))) tcluAll<-NULL nCum<-cumsum(c(0,nn)) kCum<-cumsum(c(0,k)) for(i in 1:m){ ids<-(nCum[i]+1):nCum[i+1] itclu<-tclu[[i]] iM<-M[ids, ids] crit<-unclass(by(data = apply(iM,funWay[1],fun, na.rm=TRUE),itclu,FUN = mean)) if(length(funWay)==2) crit<-crit+unclass(by(data = apply(iM,funWay[2],fun, na.rm=TRUE),itclu,FUN = mean)) r<-rank(-crit)+kCum[i] itclu<-r[as.character(itclu)] attr(itclu,"reorder")<-r rAll<-c(rAll,r) tcluAll<-c(tcluAll, list(itclu)) } if(!returnList) tcluAll<-unlist(tcluAll) attr(tcluAll,"reorder")<-rAll return(tcluAll) }else{ crit<-unclass(by(data = apply(M,funWay[1],fun, na.rm=TRUE),tclu,FUN = mean)) if(length(funWay)==2) crit<-crit+unclass(by(data = apply(M,funWay[2],fun, na.rm=TRUE),tclu,FUN = mean)) r<-rank(-crit) tclu<-r[as.character(tclu)] attr(tclu,"reorder")<-r return(tclu) } }blockmodeling/R/recode.R0000644000176200001440000000140113677022067014656 0ustar liggesusers#' @encoding UTF-8 #' @title Recode #' #' @description #' Recodes values in a vector. #' # #' @usage recode(x, oldcode = sort(unique(x)), newcode) #' #' @param x A vector. #' @param oldcode A vector of old codes. #' @param newcode A vector of new codes. #' #' @return A recoded vector. #' #' @examples #' x <- rep(1:3, times = 1:3) #' newx <- recode(x, oldcode = 1:3, newcode = c("a", "b", "c")) #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' #' @keywords manip #' #' @export "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.R0000644000176200001440000000052713677022067016132 0ustar liggesusers#' @rdname plotMat #' @export "plot.critFun" <- function( x,#an "critFun" 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,...) } #' @rdname plotMat #' @method plot crit.fun #' @export plot.crit.fun<-plot.critFunblockmodeling/R/expandMat.R0000644000176200001440000000102314026571735015336 0ustar liggesusers#' @encoding UTF-8 #' @title Expands a square matrix by repeating each row/column the specified number of times. #' @param mat A square matrix to be exapanded #' @param nn A vector of number of times each row/column must be repeated. Its length must match the number of rows/columns #' @return Sum of squared deviations from the mean using only valid (non NA) values. #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' #' @keywords manip #' @export expandMat<-function(mat, nn){ v<-rep(1:length(nn),nn) mat[v,v] } blockmodeling/R/nkpar.R0000644000176200001440000000032413677022067014533 0ustar liggesusers#' @rdname nkpartitions #' #' @export "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.R0000644000176200001440000001427013677022067014147 0ustar liggesusers#' @encoding UTF-8 #' @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. #' #' @param M Matrix or a 3 dimensional array representing the network. The third dimension allows for several relations to be analyzed. #' @param E Initial (dis)similarity in terms of regular equivalnece. #' @param iter The desired number of iterations. #' @param until.change Should the iterations be stopped when no change occurs. #' @param use.diag Should the diagonal be used. If \code{FALSE}, all diagonal elements are set to 0. #' @param normE Should the equivalence matrix be normalized after each iteration. #' #' @return #' \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 #' #' @keywords cluster graphs #' @importFrom stats as.dist #' #' @export "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/relInv.R0000644000176200001440000000137114026570334014654 0ustar liggesusers#' @encoding UTF-8 #' @title Functions for computing "relative inverse" (\code{x[1]/x}). #' #' @description #' For a vector x, it computes \code{x[1]/x}. For \code{relInv2}, if certain elements of the result are not finite (e.g. if certain elements of x are 0), these elements are replaced with 0s. #' #' @param x A numeric vector. For \code{relInv} it should not contain 0s (while for \code{relInv2} it can). #' @return A vector computed as \code{x[1]/x}. For \code{relInv2}, if the non-finite elements are replaced with 0s. #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' #' @keywords manip #' @export relInv<-function(x)x[1]/x #' @rdname relInv #' #' @export relInv2<-function(x){ x<-x[1]/x x[!is.finite(x)]<-0 x } blockmodeling/R/nkpartitions.R0000644000176200001440000000665713677022067016164 0ustar liggesusers#' Functions for listing all possible partitions or just counting the number of them #' #' The function \code{nkpartitions} lists all possible partitions of n objects in to k clusters. #' # #' @usage nkpartitions(n, k, exact = TRUE, print = FALSE) # #' nkpar(n, k) #' #' @param n Number of units/objects. #' @param k Number of clusters/groups. #' @param exact Search for partitions with exactly \code{k} or at most \code{k} clusters. #' @param print Print results as they are found. #' #' @return 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 #' #' @keywords cluster #' #' @export "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.R0000644000176200001440000000124113717551405015755 0ustar liggesusers#' @rdname plotMat #' @export "plot.optPar" <- function( x,#an "optParMode" 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)) l<-length(x$best) if(l==0)l<-1 if(which>l){ 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=IM(x,which=which),main=main,...) } #' @rdname plotMat #' @method plot opt.par #' @export plot.opt.par<-plot.optParblockmodeling/R/RF.R0000644000176200001440000000631514306422503013722 0ustar liggesusers#' @encoding UTF-8 #' @title Calculate the value of the Relative Fit function #' #' @description The function calculates the value of the Relative Fit function. Currently implemented only for one-relational one-mode or two-mode networks. #' @param res An object returned by the function \code{optRandomParC}. #' @param m The number of randomized networks for the estimation of the expected value of a criterion function. It has to be as high as possible. Defaults to 10. #' @param loops Whether loops are treated the same as any other values or not. #' @return #' \itemize{ #' \item \code{RF} - The value of the Relative Fit function. #' \item \code{err} - The value of a criterion function that is used for blockmodeling (for empirical network). #' \item \code{rand.err} - A vector with the values of the criterion function that is used for blockmodeling (for randomized networks). #' } #' @details The function randomizes an empirical network to compute the value of the Relative Fit function. #' The networks are randomized in such a way that the values on the links are randomly relocated. Other approaches to #' randomization also exist and might be more appropriate in some cases, see Cugmas et al. (2021). #' @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) #' #' res <- optRandomParC(M = net, k = 2, rep = 10, approaches = "hom", homFun = "ss", blocks = "com") #' RF(res = res, m = 100, loops = TRUE) #' @seealso \code{optRandomParC} #' @author Marjan Cugmas and Aleš Žiberna #' @references Cugmas, M., Žiberna, A., & Ferligoj, A. (2021). The Relative Fit measure for evaluating a blockmodel. Statistical Methods & Applications, 30(5), 1315-1335. \doi{10.1007/s10260-021-00595-1} #' @export RF <- function(res, m = 10, loops = NULL){ if (is.null(loops)) loops <- dim(res$M)[1] != dim(res$M)[2] errs <- vector(length = m) for (i in 1:m){ if (loops){ randomized <- matrix(sample(res$M, replace = FALSE), nrow = nrow(res$M)) } else { randomized <-matrix(0, nrow = nrow(res$M), ncol = ncol (res$M)) offD <- diag(nrow(res$M))!=1 randomized[offD] <- matrix(sample(res$M [offD] , replace = FALSE), nrow = nrow(res$M)) diag(randomized) <- diag(res$M) } if (err(res) != 0){ par <- res$initial.param names(par) <- gsub(pattern = "dots.", replacement = "", fixed = TRUE, x = names(par)) par$dots <- NULL par$M[,] <- randomized utils::capture.output(res.rand <- do.call(optRandomParC, args = par)) errs[i] <- err(res.rand) } } return(list("RF" = ifelse(err(res) == 0, yes = 1, no = 1 - err(res)/mean(errs)), "err" = err(res), "rand.err" = unlist(ifelse(err(res) == 0, yes = NA, no = list(errs))))) } blockmodeling/R/gplot.R0000644000176200001440000000740014214024302014525 0ustar liggesusers#' A wrapper for function gplot - Two-Dimensional Visualization of Graphs #' #' 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, ...) #' #' @param M A matrix (array) of a graph or set thereof. This data may be valued. #' @param 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. #' @param 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}. #' @param displaylabels Boolean; should vertex labels be displayed. #' @param boxed.labels Boolean; place vertex labels within boxes. #' @param arrowhead.cex An expansion factor for edge arrowheads. #' @param loop.cex An expansion factor for loops; may be given as a vector, if loops are to be of different sizes. #' @param 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. #' @param edge.col Color for edges; may be given as a vector or adjacency matrix, if edges are to be of different colors. #' @param edge.len If \code{uselen == TRUE}, curved edge lengths are scaled by \code{edge.len}. #' @param uselen Boolean; should we use \code{edge.len} to rescale edge lengths. #' @param usecurve Boolean; should we use \code{edge.curve}. #' @param \dots Additional arguments to \code{\link{plot}} or \code{link{sna::gplot}}:\cr\cr #' \bold{\code{mode}}: the vertex placement algorithm; this must correspond to a \code{gplot.layout} function from package \code{sna}. #' #' @return Plots a graph. #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' @seealso \code{link{sna::gplot}} #' @keywords graphs #' @importFrom grDevices gray #' #' @export "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) } #' @rdname gplot1 #' #' @export "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/find.m2.R0000644000176200001440000000246413677022067014664 0ustar liggesusers#' @rdname find.m #' #' @export "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 critFun ){ 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/MD50000644000176200001440000001435314471422772013413 0ustar liggesusersa4f3f1b6ae87238a08d3ebbd2748a8fd *CHANGES 3bd5814e8d04c05a39db1cfdc4c92a09 *DESCRIPTION 536c873c555c08bbb5d46bf0a1a5951a *NAMESPACE ff8507bd9618b6be02e60b1401ce8913 *R/REGE.FC.R a025fcd4e42cbd697aff9e236ebd6108 *R/REGE.FC.ow.R 4b7067596debde2af8a8126c732a1d3c *R/REGE.R 46fa006c67425ed91db71c10bca4e07f *R/REGE.ow.R ebb2bb339d9fe35a68af97fc81eb207c *R/REGE_for.R cb44bac947045948198efc883da857a2 *R/RF.R 0c6e2e3b834e60cdaa830e46d15e8c5a *R/blockmodeling-package.R f58d2084fa5b53e126295d6a1d7086eb *R/canClu.R e0e29db17709e0362cb20bf48d6e56fc *R/clu.R fc4334db69d98fbe04c7152c72928c22 *R/critFunC.R c537707b09cfbdc01b418da6d1124cca *R/critFunCinternalFunctions.R 0e01dd558ce2ae247c0ccc7a96cb3c59 *R/data.R 9914bb2f80945661587dcd84b42ec28c *R/expandMat.R 729af93b09e48b54b9eb30e44e69bf9c *R/find.cut.R f44c5daef98800588eb898c6975a4253 *R/find.m.R a9d0db6b3a2f2bd7ba1258df86777f38 *R/find.m2.R 0c59b8c9aca6e235a30cbdcafedc66ce *R/formatA.R 718e9ee445100d2f3904bf6988d1282a *R/fun.by.blocks.default.R 3a4e3dccfad457b69e54e906f6f38eb0 *R/fun.by.blocks.opt.more.par.R 0a414b2062c1aec154f1e6736f4b34b3 *R/funByBlocks.R 8008d09a47dafb042943e3debe886f33 *R/genMatrixMult.r a258b5c12fce28be91c57ac3e43908dc *R/genRandomPar.R 6471680113a196880a13826db1279a70 *R/genRandomParGroups.R 9744cd58c41c5f93c1ec2134abfe7428 *R/gplot.R 6feaa9021e600269173cb9da34504be9 *R/ircNorm.R 3c93e1ab79dd3d199cd028ad0fce4030 *R/loadmatrix.R 506242e5ffd842d0b4757af57e6a7193 *R/loadnetwork.R eced2399f4fc289ef619c5e58256c859 *R/loadnetwork2.R 18893ea4a47b9dd116be012c714bf88f *R/loadnetwork3.R 8695e6ffe310dfccb28b3bb8e53da287 *R/loadnetwork4.R eb6b43213a3ad20c5ddef51a90218eae *R/loadpajek.R f5844533c201ad31e063d99b6c3444e8 *R/loadvector.R cd9132067999b56125d0368b1eb1d77b *R/loadvector2.R ef2edf6e5ff44270119306a108458aac *R/mean.max.col.R c5c9b0bb964a09c8ca251539ce0b65bc *R/mean.max.row.R 0949efc03bfecf760f309b6cd674e915 *R/meanpos.R 43426e30a88be3ee5fa31754ef3d14d4 *R/nanRep.R 8c1482a08c3532ee2edd4a33f83c6f47 *R/nkpar.R 6065b6b656febcc06c46f5e205ab6a4a *R/nkpartitions.R 9a9d8e02522f0fae0b6229920857ae95 *R/notesBorrowing.R 6726cddb48bfcad4509bb22b72cdf9cf *R/onAttach.R 05f412bf7f6f1d4ded62acd0ba0f2b8a *R/one2two.R c91cb1e5db58e7ae856e128737326144 *R/optRandomParC.R 4fad2f30adac6f61b923bfc0014ec175 *R/orderClu.R 85b3127c3cea0e54ff37382b36e04226 *R/parOKgroups.R 2b109b289b4ea551f8b93c1f61625dde *R/plot.check.these.par.R 4ef9a4195e30f4084eb82728f9d534bd *R/plot.crit.fun.R 6ed3260cbd2376396524517afd4accd8 *R/plot.mat.nm.R 8befdbf701b36ecc0042737f0e5f26d0 *R/plot.opt.more.par.R 90d3b6e7598a98a9737920ddbcd9cf4a *R/plot.opt.more.par.mode.R daf9c705f1e1d67f5220d7be211d985d *R/plot.opt.par.R 275fa177e145ab18166fbfc5f46c57cf *R/plot.opt.par.mode.R 01d324874571ce47eb06b6f93a82f7d1 *R/plotMat.R e8560e4f949fc5c7035189f870a64273 *R/printBlocks.R 4c8eefb3d6de416388d32fda2691e6e2 *R/printRes.R 6d815ac48f68f8251ee9e1908ae4ab4a *R/rand-multiple.R cb9dbafff6f238b950a92c0b240c1025 *R/recode.R b4e507db9b1e179e4c49f7286ddc2933 *R/relInv.R c1471e7102889f0cf3b1879c3b52f73f *R/reorderImage.R 5edcfcd8c4db41f128a886081ca3ecb7 *R/savematrix.R 49e40c21f2ebdbf04ad5ffdcc3843654 *R/savenetwork.R 3b3ca7b333d508bda8d08e84562780a9 *R/savevector.R e52af8d8b5a338e5c124e76b88ca5c06 *R/sedist.R f0b7745f2c2fb9ce9e04dee780bd45c2 *R/splitClu.R d3d9923fa9e7d400c0eef0df8d6cb07f *R/ss.R 83f0894ed4e7b2baebc45ce5e4d3ea1a *R/sumpos.R 3c0470a39c9cfe729b91535a7bc25df4 *R/two2one.R 0e9a53f878d14eedc74fc8cf7632b4d5 *R/unlistClu.R 0a228c1e5008d3be85f42d6082fa73f5 *R/unlistCluInt.R cf56197339441d8de415e553dd25c348 *R/useneg.R 4c2cfa53f258d295e139a924e2208646 *R/usepos.R afbe4209b3bb961ba3e41cbfe79ea507 *build/partial.rdb 8a08a96533f4b1a44c2a6388ac6327f2 *data/baker.rda a99b8bfa34426e38f9cdd2834c287e4b *data/notesBorrowing.RData 55c63433d67cb665645bdf30e224fbe8 *inst/CITATION fd3f2ca732a24f8baac04e00fb94d8e6 *man/Pajek.Rd fcbcb4d2b1433b21f7da05b8f0354c31 *man/REGE.Rd bf1fa699102f149d4d3c6fdeac0aaf94 *man/RF.Rd aa03ae102504a12c8ecf07f8dd845079 *man/baker.Rd 69ce195521750805aad00de2f2937e3d *man/blockmodeling.Rd b973434f34a18954f83a959f422149b5 *man/canClu.Rd 4e553af122608bd708a490b482a8b52b *man/clu.Rd 5c3b059f353ce41faba95d44ddc385e4 *man/critFunC.Rd db29c28cb315e5804e5baf94a5a572ce *man/expandMat.Rd 29846790266e614ca698f794bcbaa07c *man/find.m.Rd 7175c1a4a9b0e7c3619f78b8343a0724 *man/formatA.Rd 8262f12e467b94f69864725e89f7cb43 *man/funByBlocks.Rd cf8997b03bee9d5c6999f04a5a97d6bd *man/genMatrixMult.Rd fde98b5245ac97f3828985171b6caf56 *man/genRandomPar.Rd e3c1b194e6cdaa72a61073461719e23d *man/gplot1.Rd 9854d5c0f60b1976bb18b0522db1c5e6 *man/ircNorm.Rd 6ed92f4642658097455deb97f404ce9f *man/nanRep.Rd dabd263af46b75169c380f3ddf015818 *man/nkpartitions.Rd 632908f874a3f94c368009070a47a047 *man/notesBorrowing.Rd e21f98ae4db66ff33a07f7fc9e3d8ee1 *man/optRandomParC.Rd ab932bd087388397df3201ad8bc29015 *man/orderClu.Rd bba13066efd659ef90b0a847cbf7a184 *man/plotMat.Rd 2c1de9ac6c4d6c0a8297ca5eab18cdec *man/printBlocks.Rd 0b6a43af4e0dd0f83f58516e317fd2f9 *man/rand.Rd 4b37a8eb7c6e947638900b72956c787e *man/recode.Rd 60e9cda73345ca85717d6760abe30f4d *man/relInv.Rd cf47e39e94e61535193d3600f3f202f4 *man/reorderImage.Rd a932b77d048140b14035850443d0ff94 *man/sedist.Rd 6b4e2483ff8eba1d3c71831d2607aa4d *man/splitClu.Rd 9c126c89dce1192749102f48e170863d *man/ss.Rd 86e7b49bee3781c4267c7e1c943ecd24 *man/two2one.Rd fc6283c0c6c0dfc2090a517220fc277e *man/unlistClu.Rd 3eb0c4720500db4d455ae89aba923eef *man/unlistCluInt.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 eb840c69d5355e86749503234137994c *src/blockmodelingC.c d2c9c2cf7c538f8e260fc054bfb1b3c8 *src/init.c 3532b68b4b601c4fec18d033503e9b99 *tests/tests.R blockmodeling/inst/0000755000176200001440000000000014362271051014041 5ustar liggesusersblockmodeling/inst/CITATION0000644000176200001440000000423214471363631015206 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("", ","))) bibentry(bibtype = "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." ) bibentry(bibtype = "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." ) bibentry(bibtype = "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." ) bibentry(bibtype="Manual", title = meta$Title, author= aut, year =year, note =vers, textVersion= paste(autText," (", year, "). ",meta$Title,", ", vers, ".", sep="") ) blockmodeling/CHANGES0000644000176200001440000002126714471363741014100 0ustar liggesusersName: blockmodeling Title: Generalized and Classical Blockmodeling of Valued Networks 2023 Version: 1.1.5 Date: 2023-08-23 Changed citEntry to bibEntry. Changed to short version number for CRAN relese. Version: 1.1.4.9001 Date: 2023-08-22 Added "#' @aliases blockmodeling-package" to blockmodeling-package.R due to change in roxygen2. A CRAN maintainer request. Version: 1.1.4.9000 Date: 2023-05-09 Fixed minor bug in plotMat Commented out StochBlockTest from tests.R file. 2022 Version: 1.1.4 Date: 2022-11-17 Some minor changes to avoid warnings in CRAN Package Check. 2022 Version: 1.1.3.9000 Date: 2022-09-08 Marjan added as contributor (long overdue), some typos corrected in documentation. Small improvement in printBlocks. Improvements/bug fixes in RF function. Version: 1.1.3 Date: 2022-07-28 Some minor improvements in plotMat. Version: 1.1.2.9000 Date: 2022-07-28 plotMat and all functions calling it (plot.* methods for results of critFunC, optParC and optRandomParC) now plot the lines separating sets/modes of units (if clu is a list) with different color (red) and twice as wide as regular lines. Also several spelling errors corrected in plotMat and co documentation and comments. Version: 1.1.2.9000 Date: 2022-07-28 plotMat and all functions calling it (plot.* methods for results of critFunC, optParC and optRandomParC) now plot the lines separating sets/modes of units (if clu is a list) with different color (red) and twice as wide as regular lines. Also several spelling errors corrected in plotMat and co documentation and comments. Version: 1.1.1.9001 Date: 2022-07-25 A bug fix related to exchangeClusters. Version: 1.1.1.9000 Date: 2022-07-25 Added option to fix some clusters (they are not "optimized" but fixed as they are) + some minor changes (new unlistClu function) and documentation improvements. Version: 1.1.0.9005 Date: 2022-07-01 Some bugs fixed. Some changes to code made to eliminate NOTEs in Rcheck Version: 1.1.0.9004 Date: 2022-05-20 Some bugs in binary stochastic (homogeneity) generalized blockmodeling fixed. Some updates to documentation. Version: 1.1.0.9003 Date: 2022-05-19 Binary stochastic (homogeneity) generalized blockmodeling should be fully supported (testing needed). Version: 1.1.0.9002 Date: 2022-05-11 Added support for row/column-dominant blocks for binary and valued blockmodeling. Version: 1.1.0.9001 Date: 2022-05-05 Started adding support for stochastic (homogeneity) generalized blockmodeling. Version: 1.0.10 Date: 2022-04-01 A bug in plotMat corrected that caused -Inf "labels" being plotted instead of values in some cases. Version: 1.0.9 Date: 2022-03-23 A bug in funByBlocks corrected. The function did not officially support multi-relational netowrks, but actually they were supproted, while it was expected that thay were represented with an array, where the first dimmension represented the relation. No this was changed so that the last/third relation represents the relation as it is implemented in in most other functions, e.g. in critFunC and optRandomParC. Version: 1.0.8 Date: 2022-02-24 A line added to print.optMorePar to print a line with the number of solutions with the same error. A printed message in optRandomParC corrected (the number of solutions with minimal error). "tests" directory added with currently only one file. The plan is to add some tests here, possibly also some automatic. 2021 Version: 1.0.7 Date: 2021-10-21 A bug in plotMat when using parameter MplotValues (introduced in version 1.0.6) fixed. Date: 2021-09-22 An option added to use load-balancing or ordinary parLapply. A bug fixed that could in some cases (when parLapplyLB was used and no random functions were used on the master) lead to an error that ".Random.seed" is not found. A parameter useRegParrallaBackend was added so that already registered parallel backend is only used if explicitly asked for. Version: 1.0.6 Date: 2021-09-17 Changed default parallel backend to foreach --> default is now useParLapply = FALSE. cl argument is now taken into account also if foreach is used. plotMat was given an additional parameter MplotValues, where a character matrix of the same dimensions as x/M can be supplied, which values are then printed in cells instead of the values of M. Date: 2021-08-27 A "NOTE" in cran checked fixed - no longer existing web page. Version: 1.0.5 Date: 2021-07-26 Added function for printing of results of optRandomParC. Added function for ordering a partition and an option to order a partition before plotting with plotMat or using it in funByBlocks. Version: 1.0.4 Date: 2021-07-20 A bug fixed so that the value of switch.names in optRandomParC should be now set correctly by defaults. This makes sure that in cases where blockmodel is not pre-specified we do not get solutions that differ only in the order of groups. Also, functions for findind canonical partition and unique canonical partitions were added. Version: 1.0.3 Date: 2021-06-01 Utility functions added. Relative fit function added. Version: 1.0.2 Date: 2021-03-24 Utility functions added. Date: 2021-02-01 plot.array removed - only goes by name plotArray. Minor bug fixes. 2020 August 1, 2020 Version 1.0.1 Various bugs fixed. July 1, 2020 Version 1.0.0 Modified optRandomParC so that packages doRng, doParallel and foreach are not loaded unless explicitly requested. June 9, 2020 Version 0.3.8 Added helpfile for baker data in an R package (see R/data.r). June 7, 2020 Version 0.3.7 Added baker data in an R package (see data folder). May 27, 2020 Version 0.3.6 Moved to Roxygen2 for generating NAMESPACE and help files. Moved to parLapplyLB {parallel} as primary way of parallel execution. January 28, 2020 Version 0.3.6 Changed DESCRIPTION and NAMESPACE as packages doRng, doParallel and foreach were moved to suggests (from Depends). To comply with CRAN rules as doRng was oprhaned. 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 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).