blockmodeling/0000755000176200001440000000000014114263762013071 5ustar liggesusersblockmodeling/NAMESPACE0000644000176200001440000000474614077503476014332 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(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/0000755000176200001440000000000014112161612013767 5ustar liggesusersblockmodeling/data/notesBorrowing.RData0000644000176200001440000000041614112161715017732 0ustar liggesusers r0b```b`add`b2Y# '/I-v/*/K*dpI (Տ\Aw@.N+Ai(m&oׁ"a`샹@wV Rqf 큻h2hhS@U/,HASǁ&]8zObO54>* GI|R2d)^P yєp%Pu1n`blockmodeling/data/baker.rda0000644000176200001440000000070414112161715015550 0ustar liggesusersU_KARgPQdTQ/ٕ s3PKWfٽhWEgonwL38X6? p 6z>0vRfBF]ci=Twh堉 y8;IZ9P>.vK#sARyi:orKdeUg9o+Zº|{QVZ*afOUX7tU+L L ?j )blockmodeling/man/0000755000176200001440000000000014112161612013631 5ustar liggesusersblockmodeling/man/baker.Rd0000644000176200001440000000154514006201705015211 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{baker} \alias{baker} \title{Citation data between social work journals for the 1985-86 period} \format{ An object of class \code{matrix} (inherits from \code{array}) with 20 rows and 20 columns. } \usage{ data(baker) } \description{ This example consists of the citation data between social work journals for the 1985-86 period, collected and analyzed in Baker (1992) } \examples{ # data(baker) # Transforming it to matrix format # baker <- as.matrix(baker) # putting zeros on the diagonal # diag(baker) <- 0 } \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 } \keyword{datasets} blockmodeling/man/funByBlocks.Rd0000644000176200001440000000726514077547045016375 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fun.by.blocks.default.R, % R/fun.by.blocks.opt.more.par.R, R/funByBlocks.R \name{funByBlocks.default} \alias{funByBlocks.default} \alias{funByBlocks.optMorePar} \alias{funByBlocks.opt.more.par} \alias{funByBlocks} \alias{fun.by.blocks} \title{Computation of function values by blocks} \usage{ \method{funByBlocks}{default}( x = M, clu, M = x, ignore.diag = "default", sortNames = TRUE, FUN = "mean", ... ) \method{funByBlocks}{optMorePar}(x, which = 1, orderClu = FALSE, sortNames = NULL, ...) \method{funByBlocks}{opt.more.par}(x, which = 1, orderClu = FALSE, sortNames = NULL, ...) funByBlocks(x, ...) fun.by.blocks(x, ...) } \arguments{ \item{x}{An object of suitable class or a matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network can have one or more modes (different kinds of units with no ties among themselves. If the network is not two-mode, the matrix must be square.} \item{clu}{A partition. Each unique value represents one cluster. If the network is one-mode, then this should be a vector, else a list of vectors, one for each mode.} \item{M}{A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network can have one or more modes (different kinds of units with no ties among themselves. If the network is not two-mode, the matrix must be square.} \item{ignore.diag}{Should the diagonal be ignored.} \item{sortNames}{Should the rows and columns of the matrix be sorted based on their names.} \item{FUN}{The function to be computed over the blocks.} \item{\dots}{Further arguments to \code{funByBlocks.default}.} \item{which}{Which (if several) of the "best" solutions should be used.} \item{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}.} } \value{ A numerical matrix of \code{FUN} values by blocks, induced by a partition \code{clu}. } \description{ Computes a value of a function over blocks of a matrix, defined by a partition. } \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) } \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{optRandomParC}}, \code{\link{optParC}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{cluster} \keyword{math} blockmodeling/man/notesBorrowing.Rd0000644000176200001440000000250013677051507017156 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/notesBorrowing.R \docType{data} \encoding{UTF-8} \name{notesBorrowing} \alias{notesBorrowing} \title{The notes borrowing network between social-informatics students} \format{ The data set is a valued matrix with 13 rows and columns. } \usage{ data("notesBorrowing") } \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). } \examples{ data(notesBorrowing) # Plot the network. # (The function plotMat is from blockmodeling package.) # plotMat(nyt) } \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 } \keyword{datasets} blockmodeling/man/expandMat.Rd0000644000176200001440000000126214075775361016066 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/expandMat.R \encoding{UTF-8} \name{expandMat} \alias{expandMat} \title{Expands a square matrix by repeating each row/column the specified number of times.} \usage{ expandMat(mat, nn) } \arguments{ \item{mat}{A square matrix to be exapanded} \item{nn}{A vector of number of times each row/column must be repeated. Its length must match the number of rows/columns} } \value{ Sum of squared deviations from the mean using only valid (non NA) values. } \description{ Expands a square matrix by repeating each row/column the specified number of times. } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{manip} blockmodeling/man/nkpartitions.Rd0000644000176200001440000000335113667647704016700 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nkpar.R, R/nkpartitions.R \name{nkpar} \alias{nkpar} \alias{nkpartitions} \title{Functions for listing all possible partitions or just counting the number of them} \usage{ nkpar(n, k) nkpartitions(n, k, exact = TRUE, print = FALSE) } \arguments{ \item{n}{Number of units/objects.} \item{k}{Number of clusters/groups.} \item{exact}{Search for partitions with exactly \code{k} or at most \code{k} clusters.} \item{print}{Print results as they are found.} } \value{ The matrix or number of possible partitions. } \description{ The function \code{nkpartitions} lists all possible partitions of n objects in to k clusters. } \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 } \author{ Chris Andrews } \keyword{cluster} blockmodeling/man/gplot1.Rd0000644000176200001440000000500513677051507015346 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gplot.R \name{gplot1} \alias{gplot1} \alias{gplot2} \title{A wrapper for function gplot - Two-Dimensional Visualization of 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, ... ) } \arguments{ \item{M}{A matrix (array) of a graph or set thereof. This data may be valued.} \item{diag}{Boolean indicating whether or not the diagonal should be treated as valid data Set this \code{TRUE} if and only if the data can contain loops. \code{diag} is \code{FALSE} by default.} \item{displaylabels}{Boolean; should vertex labels be displayed.} \item{boxed.labels}{Boolean; place vertex labels within boxes.} \item{loop.cex}{An expansion factor for loops; may be given as a vector, if loops are to be of different sizes.} \item{edge.lwd}{Line width scale for edges; if set greater than 0, edge widths are scaled by \code{edge.lwd*dat}. May be given as a vector or adjacency matrix, if edges are to have different line widths.} \item{edge.col}{Color for edges; may be given as a vector or adjacency matrix, if edges are to be of different colors.} \item{rel.thresh}{Real number indicating the lower relative (compared to the highest value) threshold for tie values. Only ties of value \code{thresh} are displayed. By default, \code{thresh = 0}.} \item{\dots}{Additional arguments to \code{\link{plot}} or \code{gplot} from package \code{sna}:\cr\cr \bold{\code{mode}}: the vertex placement algorithm; this must correspond to a \code{gplot.layout} function from package \code{sna}.} \item{uselen}{Boolean; should we use \code{edge.len} to rescale edge lengths.} \item{usecurve}{Boolean; should we use \code{edge.curve}.} \item{edge.len}{If \code{uselen == TRUE}, curved edge lengths are scaled by \code{edge.len}.} \item{arrowhead.cex}{An expansion factor for edge arrowheads.} } \value{ Plots a graph. } \description{ The function calls function \code{gplot} from the library \code{sna} with different defaults. Use fun for plotting image graphs. } \seealso{ \code{sna:gplot} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{graphs} blockmodeling/man/reorderImage.Rd0000644000176200001440000000265713667647704016570 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reorderImage.R \encoding{UTF-8} \name{reorderImage} \alias{reorderImage} \title{Reordering an image matrix of the blockmodel (or an error matrix based on new and old partition} \usage{ reorderImage(IM, oldClu, newClu) } \arguments{ \item{IM}{An image or error matrix.} \item{oldClu}{Old partition.} \item{newClu}{New partition, the same as the old one except for class labeles.} } \value{ Reorder matrix (rows and columns are reordred). } \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. } \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{plot.mat}}, \code{\link{clu}}, \code{\link{IM}}, \code{\link{err}} } \author{ Ales Ziberna } \keyword{manip} blockmodeling/man/rand.Rd0000644000176200001440000000513714026573212015061 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rand-multiple.R \encoding{UTF-8} \name{rand} \alias{rand} \alias{crand} \alias{rand2} \alias{crand2} \title{Comparing partitions on one or multiple sets of units} \usage{ rand(clu1, clu2, tab) crand( clu1, clu2, tab, multiSets = c("weights", "unlist"), weights = c("size", "equal"), returnIndividual = "attr" ) rand2(clu1, clu2) crand2(clu1, clu2) } \arguments{ \item{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.} \item{clu2}{If \code{clu1} is partition or a list of partitions, this must be a comaptible the second partition or list of partitions.} \item{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.} \item{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).} \item{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).} \item{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"}} } \value{ 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}. } \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. } \references{ Hubert, L., & Arabie, P. (1985). Comparing Partitions. Journal of Classification, 2(1), 193-218. } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{cluster} blockmodeling/man/find.m.Rd0000644000176200001440000000755213677051507015324 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find.cut.R, R/find.m.R, R/find.m2.R \encoding{UTF-8} \name{find.cut} \alias{find.cut} \alias{find.m} \alias{find.m2} \title{Computing the threshold} \usage{ find.cut(M, clu, alt.blocks = "reg", cuts = "all", ...) 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, ...) } \arguments{ \item{M}{A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network can have one or more modes (different kinds of units with no ties among themselves. If the network is not two-mode, the matrix must be square.} \item{clu}{A partition. Each unique value represents one cluster. If the network is one-mode, then this should be a vector, else a list of vectors, one for each mode.} \item{alt.blocks}{Only one of allowed blocktypes, as alternative to the null block:\cr "com" - complete block\cr "rdo", "cdo" - row and column-dominant blocks (binary, valued, and implicit approach only)\cr "reg" - (f-)regular block\cr "rre", "cre" - row and column-(f-)regular blocks\cr "rfn", "cfn" - row and column-dominant blocks (binary, valued, and implicit approach only)\cr "den" - density block (binary approach only)\cr "avg" - average block (valued approach only).} \item{cuts}{The cuts, which should be evaluated. If \code{cuts="all"} (default), all unique values are evaluated.} \item{\dots}{Other parameters to \code{critFunC}.} \item{diag}{(default = \code{TRUE}) Should the special status of diagonal be acknowledged.} \item{cormet}{Which method should be used to correct for different maximum error contributions\cr "none" - no correction\cr "censor" - censor values larger than \code{M}\cr "correct" - so that the maximum possible error contribution of the cell is the same regardless of a condition (either that something must be 0 or at least \code{M}).} \item{half}{Should the returned value of m be one half of the value where the inconsistencies are the same.} \item{FUN}{(default = "max") Function f used in row-f-regular, column-f-regular, and f-regular blocks.} \item{neval}{A number of different \code{m} values to be evaluated.} \item{ms}{The values of m where the function should be evaluated.} } \value{ A matrix of maximal \code{m/cut} values. } \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". } \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 } \seealso{ \code{\link{critFunC}} and maybe also \code{\link{optParC}}, \code{\link{plotMat}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{cluster} blockmodeling/man/sedist.Rd0000644000176200001440000000756513677051507015450 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sedist.R \encoding{UTF-8} \name{sedist} \alias{sedist} \title{Computes distances in terms of Structural equivalence (Lorrain & White, 1971)} \usage{ sedist( M, method = "default", fun = "default", fun.on.rows = "default", handle.interaction = "switch", use = "pairwise.complete.obs", ... ) } \arguments{ \item{M}{A matrix representing the (usually valued) network. For now, only one-relational networks are supported. The network must be one-mode.} \item{method}{The method used to compute distances - any of the methods allowed by functions dist, \code{"cor"} or \code{"cov"} (all \code{package::stats}) or just \code{"cor"} or \code{"cov"} (given as a character).} \item{fun}{Which function should be used to compute distances (given as a character).} \item{fun.on.rows}{For non-standard function - does the function compute measure on rows (such as \code{"cor"}, \code{"cov"},...) of the data matrix (as opposed to computing measure on columns (such as \code{dist}).} \item{handle.interaction}{How should the interaction between the vertices analysed be handled:\cr \code{"switch"} (the default) - assumes that when comparing units i and j, M[i,i] should be compared with M[j,j] and M[i,j] with M[j,i]. These two comparisons are weighted by 2. This should be used with Euclidean distance to get the corrected Euclidean distance with p = 2.\cr \code{"switch2"} - the same (alias)\cr \code{"switch1"} - the same as above, only that the two comparisons are weighted by 1. This should be used with Euclidean distance to get the corrected Wuclidean distance with p = 1.\cr \code{"ignore"} (diagonal) - Diagonal is ignored. This should be used with Euclidean distance to get the corrected Euclidean distance with p = 0.\cr \code{"none"} - the matrix is used "as is"} \item{use}{For use with methods \code{"cor"} and \code{"cov"}, for other methods (the default option should be used if \code{handle.interaction == "ignore"}), \code{"pairwise.complete.obs"} are always used, if \code{stats.dist.cor.cov = TRUE}.} \item{\dots}{Additional arguments to \code{fun}} } \value{ A matrix (usually of class dist) is returned. } \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. } \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". } \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)) } \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 } \seealso{ \code{\link{dist}}, \code{\link{hclust}}, \code{\link{REGE}}, \code{\link{optParC}}, \code{\link{optParC}}, \code{\link{optRandomParC}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{cluster} \keyword{graphs} blockmodeling/man/ss.Rd0000644000176200001440000000131214026573212014551 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ss.R \encoding{UTF-8} \name{ss} \alias{ss} \alias{ssNa} \alias{ad} \title{Sum of Squared deviations from the mean and sum of Absolute Deviations from the median} \usage{ ss(x) ssNa(x) ad(x) } \arguments{ \item{x}{A numeric vector.} } \value{ Sum of Squared deviations from the mean or sum of Absolute Deviations from the median. } \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. } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{univar} blockmodeling/man/blockmodeling.Rd0000644000176200001440000000750714075775361016766 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/blockmodeling-package.R \docType{package} \encoding{UTF-8} \name{blockmodeling} \alias{blockmodeling} \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. } \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) } \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.Rd0000644000176200001440000000104614075775361015370 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.Rd0000644000176200001440000000363313677051507016522 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 \url{http://vlado.fmf.uni-lj.si/pub/networks/pajek/} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{cluster} blockmodeling/man/two2one.Rd0000644000176200001440000000414313667647704015550 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.Rd0000644000176200001440000001356313677051507014672 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.Rd0000644000176200001440000000155513667647704015550 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.Rd0000644000176200001440000000111113667647704015404 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.Rd0000644000176200001440000003417313677051507015665 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 ) optParC( M, clu, approaches, blocks, nMode = NULL, isSym = NULL, diag = 1, useMulti = FALSE, maxPar = 50, IM = NULL, EM = NULL, Earr = NULL, justChange = TRUE, sameIM = FALSE, regFun = "max", homFun = "ss", usePreSpecM = NULL, preSpecM = NULL, minUnitsRowCluster = 1, minUnitsColCluster = 1, maxUnitsRowCluster = 9999, maxUnitsColCluster = 9999, relWeights = 1, posWeights = 1, blockTypeWeights = 1, combWeights = NULL, exchageClusters = "all", save.initial.param = TRUE ) } \arguments{ \item{M}{A matrix representing the (usually valued) network. For multi-relational networks, this should be an array with the third dimension representing the relation. The network can have one or more modes (diferent kinds of units with no ties among themselves). If the network is not two-mode, the matrix must be square.} \item{clu}{A partition. Each unique value represents one cluster. If the nework is one-mode, than this should be a vector, else a list of vectors, one for each mode. Similarly, if units are comprised of several sets, \code{clu} should be the list containing one vector for each set.} \item{approaches}{One of the approaches (for each relation in multi-relational netowrks in a vector) described in Žiberna (2007). Possible values are:\cr "bin" - binary blockmodeling,\cr "val" - valued blockmodeling,\cr "hom" - homogeneity blockmodeling,\cr "ss" - sum of squares homogeneity blockmodeling, and\cr "ad" - absolute deviations homogeneity blockmodeling.\cr \cr The last two options are "shorthand" for specifying \code{approaches="hom"} and \code{homFun} to either \code{"ss"} or \code{"ad"}.} \item{blocks}{A vector, a list of vectors or an array with names of allowed blocy types. \cr \cr Only listing of allowed block types (blockmodel is not pre-specified).\cr A vector with names of allowed blocktypes. For multi-relational networks, it can be a list of such vectors. For \code{approaches = "bin"} or \code{approaches = "val"}, at least two should be selected. Possible values are:\cr \code{"nul"} - null or empty block\cr \code{"com"} - complete block\cr \code{"rdo"}, \code{"cdo"} - row and column-dominant blocks (binary and valued approach only)\cr \code{"reg"} - (f-)regular block\cr \code{"rre"}, \code{"cre"} - row and column-(f-)regular blocks\cr \code{"rfn"}, \code{"cfn"} - row and column-dominant blocks (binary, valued only)\cr \code{"den"} - density block (binary approach only)\cr \code{"avg"} - average block (valued approach only)\cr \code{"dnc"} - do not care block - the error is always zero\cr The ordering is important, since if several block types have identical error, the first on the list is selected.\cr\cr A pre-specified blockmodel.\cr An array with dimensions four dimensions (see example below). The third and the fourth represent the clusters (for rows and columns). The first is as long as the maximum number of allows block types for a given block. If some block has less possible block types, the empty slots should have values \code{NA}. The second dimension is the number of relations (1 for single-relational networks). The values in the array should be the ones from above. The array can have only three dimensions in case of one-relational networks or if the same pre-specified blockmodel is assumed for all relations. Further, it can have only two dimensions, if in addition only one block type is allowed per block.} \item{isTwoMode}{\code{1} for one-mode networks and \code{2} for two-mode networks. The default value is set to \code{NULL}.} \item{isSym}{Specifying if the matrix (for each relation) is symetric.} \item{diag}{Should the special stauts of diagonal be acknowladged. The default value is set to \code{1}.} \item{IM}{The obtained image for objects. For debugging purposes only.} \item{EM}{Block errors by blocks. For debugging purposes only.} \item{Earr}{The array of errors for all allowed block types by next dimensions: allowed block types, relations, row clusters and column clusters. The dimensions should match the dimensions of the block argument if specified as an array. For debugging purposes only.} \item{justChange}{Value specifying if only the errors for changed clusters should be computed. Used only for debugging purposes by developers.} \item{rowCluChange}{An array holding the two row clusters where the change occured. Used only for debugging purposes by developers.} \item{colCluChange}{An array holding the col row clusters where the change occured. Used only for debugging purposes by developers.} \item{sameIM}{Should we damand the same blockmodel image for all relations. The default value is set to \code{FALSE}.} \item{regFun}{Function f used in row-f-regular, column-f-regular, and f-regular blocks. Not used in binary approach. For multi-relational networks, it can be a vector of such character strings. The default value is set to \code{"max"}.} \item{homFun}{In case of homogenity blockmodeling two vairability criteria can be used: \code{"ss"} - sum of squares (set by default) and \code{"ad"} - absolute deviations.} \item{usePreSpecM}{Specifiying weather a pre-specified value should be used when computing inconsistency.} \item{preSpecM}{Suficient value for individual cells for valued approach. Can be a number or a character string giving the name of a function. Set to \code{"max"} for implicit approach. For multi-relational networks, it can be a vector of such values. In case ob binary blockmodeling this argument is a threshold used for binerizing the network. Therefore all values with values lower than \code{preSpecM} are recoded into 0s, all other into 1s. For multi-relational networks, it can be a vector of such values. In case of pre-specified blockmodeling, it can have the same dimensions as \code{blocks}.} \item{save.initial.param}{Should the inital parameters (\code{approaches}, ...) be saved. The default value is \code{TRUE}.} \item{relWeights}{Weights for all type of relations in a blockmodel. The default value is set to \code{1}.} \item{posWeights}{Weigths for positions in the blockmodel (the dimensions must be the same as the error matrix (rows, columns)). For now this is a matix (two-dimensional) even for multi-relational networks.} \item{blockTypeWeights}{Weights for each type of block used, if they are to be different accros block types (see \code{blocks} above). It must be suplied in form of a named vetor, where the names are one or all allowed block types from \code{blocks}. If only some block types are specified, the other have a default weight of 1. The default value is set to \code{1}.} \item{combWeights}{Weights for all type of block used, The default value is set to \code{NULL}.The dimension must be the same as \code{blocks}, if \code{blocks} would be specified in array format (which is usual in pre-specified case).} \item{returnEnv}{Should the function also return the environment after its completion.} \item{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.} } \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.Rd0000644000176200001440000000222413667647704016751 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.Rd0000644000176200001440000000576613667647704014752 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.Rd0000644000176200001440000000771613677051507015205 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 (see Description). } \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 \url{http://vlado.fmf.uni-lj.si/pub/networks/pajek/}. de Nooy, W., Mrvar, A., & Batagelj. V. (2005). Exploratory Social Network Analysis with Pajek. London: SAGE Publications. } \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.Rd0000644000176200001440000000371714076020070015730 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} (default), dimensions that have only one level are dropped (\code{drop} function is applied to the final result).} \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}} } \author{ \enc{Aleš Žiberna}{Ales Ziberna} } \keyword{manip} blockmodeling/man/orderClu.Rd0000644000176200001440000000374114077547045015726 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.Rd0000644000176200001440000000211314075775361016576 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}} } blockmodeling/man/optRandomParC.Rd0000644000176200001440000002650114077503476016657 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 = TRUE, cl = NULL, stopcl = is.null(cl), ... ) \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 blocktypes. For multi-relational networks, it can be a list of such vectors. For \code{approaches = "bin"} or \code{approaches = "val"}, at least two should be selected. Possible values are:\cr \code{"nul"} - null or empty block\cr \code{"com"} - complete block\cr \code{"rdo"}, \code{"cdo"} - row and column-dominant blocks (binary and valued approach only)\cr \code{"reg"} - (f-)regular block\cr \code{"rre"}, \code{"cre"} - row and column-(f-)regular blocks\cr \code{"rfn"}, \code{"cfn"} - row and column-dominant blocks (binary, valued only)\cr \code{"den"} - density block (binary approach only)\cr \code{"avg"} - average block (valued approach only)\cr \code{"dnc"} - do not care block - the error is always zero\cr The ordering is important, since if several block types have identical error, the first on the list is selected.\cr\cr A pre-specified blockmodel.\cr An array with dimensions four dimensions (see example below). The third and the fourth represent the clusters (for rows and columns). The first is as long as the maximum number of allows block types for a given block. If some block has less possible block types, the empty slots should have values \code{NA}. The second dimension is the number of relations (1 for single-relational networks). The values in the array should be the ones from above. The array can have only three dimensions in case of one-relational networks or if the same pre-specified blockmodel is assumed for all relations. Further, it can have only two dimensions, if in addition only one block type is allowed per block.} \item{rep}{The number of repetitions/different starting partitions to check.} \item{save.initial.param}{Should the 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} be used (otherwise \code{mforeach} is used). Defaults to true as it needs less dependencies. It might be removed in future releses and only allow the use of parLapplyLB.} \item{cl}{The cluster to use (if formed beforehand). Defaults to \code{NULL}.} \item{stopcl}{Should the cluster be stoped after the function finishes. Defaults to \code{is.null(cl)}.} \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 \url{http://vlado.fmf.uni-lj.si/pub/networks/pajek/} Doreian, P., Batagelj, V. & Ferligoj, A. (2005). Generalized blockmodeling, (Structural analysis in the social sciences, 25). Cambridge [etc.]: Cambridge University Press. \enc{Žiberna, A.}{Ziberna, A.} (2007). Generalized Blockmodeling of Valued Networks. Social Networks, 29(1), 105-126. doi: 10.1016/j.socnet.2006.04.002 \enc{Žiberna, A.}{Ziberna, A.} (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology, 32(1), 57-84. doi: 10.1080/00222500701790207 \enc{Žiberna, A.}{Ziberna, A.} (2014). Blockmodeling of multilevel networks. Social Networks, 39(1), 46-61. doi: 10.1016/j.socnet.2014.04.002 } \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.Rd0000644000176200001440000003266014077547045015571 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.col = "blue", IM.dens = NULL, IM = NULL, wnet = NULL, wIM = NULL, use.IM = length(dim(IM)) == length(dim(M)) | !is.null(wIM), dens.leg = c(null = 100, nul = 100), blackdens = 70, plotLines = FALSE, frameMatrix = TRUE, x0ParLine = -0.1, x1ParLine = 1, y0ParLine = 0, y1ParLine = 1.1, colByUnits = NULL, colByRow = NULL, colByCol = NULL, mulCol = 2, joinColOperator = "+", colTies = FALSE, maxValPlot = NULL, printMultipliedMessage = TRUE, replaceNAdiagWith0 = TRUE, colLabels = FALSE, ... ) 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.col = "blue", IM.dens = NULL, IM = NULL, wnet = NULL, wIM = NULL, use.IM = length(dim(IM)) == length(dim(M)) | !is.null(wIM), dens.leg = c(null = 100, nul = 100), blackdens = 70, plotLines = FALSE, frameMatrix = TRUE, x0ParLine = -0.1, x1ParLine = 1, y0ParLine = 0, y1ParLine = 1.1, colByUnits = NULL, colByRow = NULL, colByCol = NULL, mulCol = 2, joinColOperator = "+", colTies = FALSE, maxValPlot = NULL, printMultipliedMessage = TRUE, replaceNAdiagWith0 = TRUE, colLabels = FALSE, ... ) } \arguments{ \item{x}{A result from a corresponding function or a matrix or similar object representing a network.} \item{main}{Main title.} \item{\dots}{Aditional 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.} \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 "decearsing" (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.col}{The color of the line that separates the partitions.} \item{IM.dens}{The density of shading lines in each block.} \item{IM}{The image (as obtained with \code{critFunC}) of the blockmodel. \code{dens.leg} is used to translate this image into \code{IM.dens}.} \item{wnet}{Specifies which matrix (if more) should be plotted - used if \code{M} is an array.} \item{wIM}{Specifies which \code{IM} (if more) should be used for plotting. The default value is set to \code{wnet}) - used if \code{IM} is an array.} \item{use.IM}{Specifies if \code{IM} should be used for plotting.} \item{dens.leg}{It is used to translate the \code{IM} into \code{IM.dens}.} \item{blackdens}{At which density should the values on dark colors of lines be printed in white.} \item{plotLines}{Should the lines in the matrix be printed. The default value is set to \code{FALSE}, best set to \code{TRUE} for very small networks.} \item{frameMatrix}{Should the matrix be framed (if \code{plotLines} is \code{FALSE}). The default value is set to \code{TRUE}.} \item{x0ParLine}{Coordinates for lines separating clusters.} \item{x1ParLine}{Coordinates for lines separating clusters.} \item{y0ParLine}{Coordinates for lines separating clusters.} \item{y1ParLine}{Coordinates for lines separating clusters.} \item{colByUnits}{Coloring units. It should be a vector of unit length.} \item{colByRow}{Coloring units by rows. It should be a vector of unit length.} \item{colByCol}{Coloring units by columns. It should be a vector of unit length.} \item{mulCol}{Multiply color when joining with row, column. Only used when when \code{colByUnits} is not \code{NULL}.} \item{joinColOperator}{Function to join \code{colByRow} and \code{colByCol}. The default value is set to \code{"+"}.} \item{colTies}{If \code{TRUE}, ties are colored, if \code{FALSE}, 0-ties are colored.} \item{maxValPlot}{The value to use as a maximum when computing colors (ties with maximal positive value are plotted as black).} \item{printMultipliedMessage}{Should the message '* all values in cells were multiplied by' be printed on the plot. The default value is set to \code{TRUE}.} \item{replaceNAdiagWith0}{If \code{replaceNAdiagWith0 = TRUE} Should the \code{NA} values on the diagonal of a matrix be replaced with 0s.} \item{colLabels}{Should the labels of units be colored. If \code{FALSE}, these are not collored, if \code{TRUE}, they are colored with colors of clusters as defined by palette. This can be aslo a vector of colors (or integers) for one-mode networks or a list of two such vectors for two-mode networks.} \item{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.Rd0000644000176200001440000000237413667647704015570 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.Rd0000644000176200001440000000407514076020070014436 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 = TRUE) } \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 allowed in randomized networks or not, default \code{TRUE}.} } \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 funcion that is used for blockmodeling (for randomized networks). } } \description{ The function calculates the value of the Relative Fit function. } \details{ The function randomizes an empirical network to compute the value of the Relative Fit function. The networks are ranomized in such a way that the values on the links are randomly relocated. } \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) # Install package blockmodeling and then run the following lines. 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. (2019). Mechanisms Generating Asymmetric Core-Cohesive Blockmodels. Metodološki Zvezki, 16(1), 17-41. } \seealso{ \code{optRandomParC} } \author{ Marjan Cugmas and Ales Ziberna } blockmodeling/man/canClu.Rd0000644000176200001440000000201614076020070015325 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.Rd0000644000176200001440000000135714075775361015411 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.Rd0000644000176200001440000000131214077503476016431 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{Niceprinting 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{ Niceprinting 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/DESCRIPTION0000644000176200001440000000225414114263762014602 0ustar liggesusersPackage: blockmodeling Type: Package Title: Generalized and Classical Blockmodeling of Valued Networks Version: 1.0.5 Date: 2021-08-27 Imports: stats, methods, Matrix, parallel Suggests: sna, doRNG, doParallel, foreach Depends: R (>= 2.10) Author: Aleš Žiberna [aut, cre] Authors@R: person("Aleš", "Žiberna", email = "ales.ziberna@gmail.com", role = c("aut", "cre")) Maintainer: Aleš Žiberna Description: This is primarily meant as an implementation of generalized blockmodeling for valued networks. In addition, measures of similarity or dissimilarity based on structural equivalence and regular equivalence (REGE algorithms) can be computed and partitioned matrices can be plotted: Žiberna (2007), Žiberna (2008), Žiberna (2014). License: GPL (>= 2) Encoding: UTF-8 RoxygenNote: 7.1.1 Repository: CRAN Repository/R-Forge/Project: blockmodeling Repository/R-Forge/Revision: 345 Repository/R-Forge/DateTimeStamp: 2021-08-27 12:45:46 Date/Publication: 2021-09-03 00:10:26 UTC NeedsCompilation: yes Packaged: 2021-08-27 13:08:29 UTC; rforge blockmodeling/src/0000755000176200001440000000000014112161612013645 5ustar liggesusersblockmodeling/src/REGE_OWNM_R.f900000644000176200001440000000440113654621042016037 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.f900000644000176200001440000000405513654621042015576 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.f900000644000176200001440000000462313654621042016631 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.f900000644000176200001440000000564713654621042015576 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.f900000644000176200001440000000577213654621042015574 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.c0000644000176200001440000000707613663463024015002 0ustar liggesusers#include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void critFun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void optPar(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void optParMulti(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void parArr2Vec(void *, void *, void *, void *, void *); extern void parVec2Arr(void *, void *, void *, void *, void *); /* .Fortran calls */ extern void F77_NAME(regd)(void *, void *, void *, void *, void *); extern void F77_NAME(regdne)(void *, void *, void *, void *, void *); extern void F77_NAME(regdow)(void *, void *, void *, void *, void *); extern void F77_NAME(regdowne)(void *, void *, void *, void *, void *); extern void F77_NAME(rege)(void *, void *, void *, void *, void *); extern void F77_NAME(regene)(void *, void *, void *, void *, void *); extern void F77_NAME(regenm)(void *, void *, void *, void *, void *); extern void F77_NAME(regenmdiag)(void *, void *, void *, void *, void *); extern void F77_NAME(regenmne)(void *, void *, void *, void *, void *); extern void F77_NAME(regeow)(void *, void *, void *, void *, void *); extern void F77_NAME(regeowne)(void *, void *, void *, void *, void *); extern void F77_NAME(regeownm)(void *, void *, void *, void *, void *); extern void F77_NAME(regeownmdiag)(void *, void *, void *, void *, void *); extern void F77_NAME(regeownmne)(void *, void *, void *, void *, void *); static const R_CMethodDef CEntries[] = { {"critFun", (DL_FUNC) &critFun, 30}, {"optPar", (DL_FUNC) &optPar, 37}, {"optParMulti", (DL_FUNC) &optParMulti, 42}, {"parArr2Vec", (DL_FUNC) &parArr2Vec, 5}, {"parVec2Arr", (DL_FUNC) &parVec2Arr, 5}, {NULL, NULL, 0} }; static const R_FortranMethodDef FortranEntries[] = { {"regd", (DL_FUNC) &F77_NAME(regd), 5}, {"regdne", (DL_FUNC) &F77_NAME(regdne), 5}, {"regdow", (DL_FUNC) &F77_NAME(regdow), 5}, {"regdowne", (DL_FUNC) &F77_NAME(regdowne), 5}, {"rege", (DL_FUNC) &F77_NAME(rege), 5}, {"regene", (DL_FUNC) &F77_NAME(regene), 5}, {"regenm", (DL_FUNC) &F77_NAME(regenm), 5}, {"regenmdiag", (DL_FUNC) &F77_NAME(regenmdiag), 5}, {"regenmne", (DL_FUNC) &F77_NAME(regenmne), 5}, {"regeow", (DL_FUNC) &F77_NAME(regeow), 5}, {"regeowne", (DL_FUNC) &F77_NAME(regeowne), 5}, {"regeownm", (DL_FUNC) &F77_NAME(regeownm), 5}, {"regeownmdiag", (DL_FUNC) &F77_NAME(regeownmdiag), 5}, {"regeownmne", (DL_FUNC) &F77_NAME(regeownmne), 5}, {NULL, NULL, 0} }; void R_init_blockmodelingRoxygen2(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, FortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } blockmodeling/src/REGD_R.f900000644000176200001440000000467713654621042015215 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.f900000644000176200001440000000573313654621042015614 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.f900000644000176200001440000000553413654621042016163 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.f900000644000176200001440000000614113654621042016171 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.f900000644000176200001440000000456713654621042015621 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.f900000644000176200001440000000705213654621042016172 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.f900000644000176200001440000000427713654621042016370 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.f900000644000176200001440000000411713654621042015203 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.c0000644000176200001440000027721013654621042016746 0ustar liggesusers/* WARNINGS: rfn and cfn blocks added only to binary and valued blockmodeling - no safety measures are in effect! This is an implementation of Generalized blockmodeling of valued (and binary) networks in C to be called from R. The structure is as follows: - main functions that are linked to R. These must include all functions for optimizing partitions - a function that computes (or updates) the criterion function of a partition and a blockmodel - functions for computing errors/inconsistencies for individual block types for all types of blockmodeling (hom,val,bin) - functions for computing row/column summaries for regular-like blocks - functions for computing measure of variation for homogeneity blockmodeling The implementation must support (when final): - several types of generalized blockmodeling, with the possibility to extend it (easily) with new types of blockmodeling or/and types of blocks - multirelational networks (with the possibility to have different or same images for all networks - at least one and two mode networks (preferably efficiently) and also 3-mode networks - efficient computations for symmetric networks - symmetrical block type (not yet implemented) - pre-specified blockmodeling - for valued blockmodeling this also means possibility to pre-specify the value from the which the deviations are computed (hom) or the value of parameter m by blocks (val) If possible, also: - possibility of different methods for "searching" for the partition - ways of optimising - eg. not only local search, but aslo gentic algorithm, tabu search, etc. - possibility to specify what kind of partitions are allowed (minimal/maximal group size, etc.) TODO: - allow penalties by relations (already implemented), by block types and by "positions". This could be implemented in C by just one 4d weighting array that could be in R computed (if desired) from those separate weighting schemes. */ #include #include #include #include #include /* Change these when you add new functions */ #define nRegFun 3 #define nHomFun 2 #define nBlockTypes 9 #define nApproaches 3 /* #define MaxNumOfDiffBlockTypes 10 */ #define min(a,b) ((a) < (b) ? (a) : (b)) #define max(a,b) ((a) > (b) ? (a) : (b)) double ss(double *px, int n, double preSpecVal); double ssP(double *px, int n, double preSpecVal); double ss0(double *px, int n, double preSpecVal); double ssPmin(double *px, int n, double preSpecVal); double ad(double *px, int n, double preSpecVal); double adP(double *px, int n, double preSpecVal); double ad0(double *px, int n, double preSpecVal); int randomInt(int n); /* A function with returns a random number on the interval [0, n-1]*/ int randomInt(int n) { int r; r = (int) (unif_rand()*n); return(r); } void randomCall(int *n, int *r); void randomCall(int *n, int *r){ GetRNGstate(); /* Get .Random.seed from R */ *r = randomInt(*n); PutRNGstate(); /* Write .Random.seed in R */ } /* Definition of an array of pointers to a function for computing some measure of variance*/ double (*phom[nHomFun][4])(double *px, int n, double preSpecVal); /* A function for computing sum of squares deviations from the mean*/ double ss(double *px, int n, double preSpecVal) { double ssx=0; double sumx=0; int i; for(i=0;i m){ m=preSpecVal; } for(i=0;i *db) - (*da < *db); } /* A function for computing sum of absolute deviations from the median*/ double ad(double *px, int n, double preSpecVal){ /*int cmp(double *x, double *y){ if(*x>*y) return(1); if(*y>*x) return((-1)); return(0); }*/ double med, sad = 0; int i; qsort(px,n,sizeof(double), cmp); if((n%2)==0){ med = ( px[n/2-1] + px[n/2])/2.0; }else{ med = px[(n)/2]; } for(i=0; i<(n/2) ;i++){ sad += med - px[i]; } for(i=n/2;i<(n);i++){ sad += px[i] - med; } return(sad); } /* A function for computing sum of absolute deviations from a given value*/ double adP(double *px, int n, double preSpecVal){ double sad = 0; int i; for(i=0; i<(n) ;i++){ sad += px[i]>preSpecVal ? (px[i]- preSpecVal): (preSpecVal - px[i]); } return(sad); } /* A function for computing sum of absolute deviations from a given value*/ double ad0(double *px, int n, double preSpecVal){ double sad = 0; int i; for(i=0; i<(n) ;i++){ sad += px[i]>0 ? (px[i]): ( - px[i]); } return(sad); } double adPmin(double *px, int n, double preSpecVal){ double med, sad = 0; int i; qsort(px,n,sizeof(double), cmp); if((n%2)==0){ med = ( px[n/2-1] + px[n/2])/2.0; }else{ med = px[(n)/2]; } if(preSpecVal > med){ med=preSpecVal; } for(i=0; i<(n/2) ;i++){ sad += med - px[i]; } for(i=n/2;i<(n);i++){ sad += px[i] - med; } return(sad); } /* Definition of an array of pointers to a function for computing some summary measure*/ double (*pregFuns[nRegFun])(double *px, int n); double maxv(double *px, int n){ double res=-INFINITY; for(int i = 0;i always returns 0*/ double doNotCare(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ return(0.0); } /* a function for computing error of the regular block - binary blockmodeling*/ double binReg(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of rows in the whole matrix/network nrb - number of rows in the block ncb - number of rows in the block */ int baseInd=relN*nr*nc; int ind2d; double *prs; double *pcs; prs = (double *) malloc(nrb*sizeof(double)); pcs = (double *) malloc(ncb*sizeof(double)); for(int i = 0; i0); } for(int i = 0; i0); } free(prs); free(pcs); return((nrb-nnr)*ncb + (ncb-nnc)*nnr); } /* a function for computing error of the column-regular block - binary blockmodeling*/ double binCre(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of columns in the whole matrix/network nrb - number of rows in the block ncb - number of columns in the block */ int baseInd=relN*nr*nc; int ind2d; double pcs=0; int nnc=0; for(int j = 0; j0); } return((ncb-nnc)*nrb); } /* a function for computing error of the row-regular block - binary blockmodeling*/ double binRre(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of columns in the whole matrix/network nrb - number of rows in the block ncb - number of columns in the block */ int baseInd=relN*nr*nc; double prs=0; int nnr=0; for(int i = 0; i0); } return((nrb-nnr)*ncb); } /* a function for computing error of the row-functional block - binary blockmodeling*/ double binRfn(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of columns in the whole matrix/network nrb - number of rows in the block ncb - number of columns in the block */ int baseInd=relN*nr*nc; double prs = 0; int nnr=0; double st=0; for(int i = 0; i0); st += prs; } return(st - nnr + (nrb-nnr)*ncb); } /* a function for computing error of the column-functional block - binary blockmodeling*/ double binCfn(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ /* nr - number of rows in the whole matrix/network nc - number of columns in the whole matrix/network nrb - number of rows in the block ncb - number of columns in the block */ int baseInd=relN*nr*nc; int ind2d; double pcs = 0; double st = 0; int nnc=0; for(int j = 0; j0); st += pcs; } return(st - nnc + (ncb-nnc)*nrb); } /* a function for computing error of the complete block - binary blockmodeling*/ double binCom(const double *pM, const int nr, const int nc, const int relN,const int nrb,const int ncb,const int *pRowInd, const int *pColInd, const int regFun, const int homFun, const int usePreSpecVal,const double preSpecVal){ double res=0; int baseInd=relN*nr*nc; int ind2d; for(int j = 0; j=nClus) nClus = pParVec[i]+1; } /* Rprintf("OK2"); */ *pnClus = nClus; /* Rprintf("OK3"); */ /*pnUnitsClu = (int *) malloc((*pnClus)*sizeof(int));*/ /*pParArr = (int *) malloc((*pnClus)*(*pn)*sizeof(int));*/ for(int i=0;i<*pn;i++){ pParArr[pParVec[i]*(*pn)+pnUnitsClu[pParVec[i]]]=i; pnUnitsClu[pParVec[i]]++; Rprintf("OK4.%i", i); } /* Rprintf("OK5"); */ } /* for now this function moves to improved partition as soon as it findes one */ /* however, the "move" is selected randomly, while it is true that "moves" are tried before "exchanges" */ void optPar(const double *pM, const int *pnr, const int *pnc, const int *pnRel, const int *pisTwoMode, const int *pisSym,const int *pdiag, const int *pnColClus, const int *pnRowClus, int *pnUnitsRowClu, int *pnUnitsColClu, int *prowParArr, int *pcolParArr,const int *papproaches, const int *pmaxBlockTypes,const int *pnBlockTypeByBlock, const int *pblocks, int *pIM, double *pEM, double *pEarr, double *perr, const int *pjustChange, int *prowCluChange, int *pcolCluChange, const int *psameIM, const int *pregFun, const int *phomFun, const int *pusePreSpec, const double *ppreSpecM, const int *pminUnitsRowCluster, const int *pminUnitsColCluster, const int *pmaxUnitsRowCluster, const int *pmaxUnitsColCluster, int *psameErr, int *pnIter, const double *pcombWeights, const int *pexchageClusters){ /* double *pM - pointer to array or matrix representiing the (multirelational) network int *pnr - pointer to the number of rows int *pnc - pointer to the number of columns int *pisTwoMode - pointer to 0 (false) or 1 (true) specifying it the network is two-mode int *pisSym - pointer to array of length (nRel - number of relation) specifying if the matrix (for each relation) is symetric) (0 - as any other value, 1 - seperately, 2 - ignore) int *pdiag - pointer to array of length (nRel - number of relation) 0 (false) or 1 (true) specifying how to treat the diagonal elments int *pnRel - pointer to the number of relations int *pnColClus - pointer to the number of column clusters int *pnRowClus - pointer to the number of column clusters int *pnUnitsRowClu - pointer to the array of the nummber of members of each row cluster int *pnUnitsColClu - pointer to the array of the nummber of members of each col cluster int *prowParArr - pointer to the array of arrays (one for each row cluster) of members of each row cluster int *pcolParArr - pointer to the array of arrays (one for each col cluster) of members of each col cluster int *papproaches - pointer to the array specifiying approach - one for each realation int *pmaxBlockTypes - pointer to maximum number of used block types int *pnBlockTypeByBlock - pointer to 3d array (Rel, row, col) specifiying the number of used allowed block types int *pblocks - pointer to the 4d array (nBlockTypesByBlock, Rel, row, col) specifiying allowed block types int *pIM - pointer to 3d array (Rel, row, col) specifiying the image matrix double *pEM - pointer to 3d array (Rel, row, col) specifiying the error for each block double *pEarr - pointer to the 4d array ((*pmaxBlockTypes), Rel, row, col) specifiying the errrors for each allowed block type - it is very important that the value is Infinitive for block types that are not allowed double *perr - pointer to the total error int *pjustChange - pointer to a value specifying if only the errors for changed clusters should be computed int *prowCluChange - pointer to an array holding the two row clusters where the change occured int *pcolCluChange - pointer to an array holding the col row clusters where the change occured int *psameIM - pointer to 0 (false) or 1 (true) specifiying if the image has to be the same for all relations int *pregFun - pointer to the 4d array ((*pmaxBlockTypes), Rel, row, col) specifiying the "summary" function used in f-regular line blocks int *phomFun - pointer to the array (one value for each rel) function used used for computing measure of variability in sum of squares blockmodeling int *pusePreSpec - pointer to 4d array ((*pmaxBlockTypes), Rel, row, col) specifiying weather a the pre-specified value should be used when computing inconsistency double *ppreSpecM - pointer to 4d array ((*pmaxBlockTypes), Rel, row, col) specifiying the pre-specified value to be used when computing inconsistency int *pminUnitsRowCluster - pointer to the minimum number of units in row cluster int *pminUnitsColCluster - pointer to the minimum number of units in col cluster int *pmaxUnitsRowCluster - pointer to the maximum number of units in row cluster int *pmaxUnitsColCluster - pointer to the maximum number of units in col cluster double *pcombWeights - pointer to a array of weights of the same dimmensions as blocks int *pexchageClusters - pointer to a matrix (nRowClust, nColClus) showing which clusters are exchangable */ /*Rprintf("OptParC\n");*/ /**/ /*Rprintf("pM: ");*/ /*for( int i=0;i<(*pnr)*(*pnc)*(*pnRel);i++){*/ /* Rprintf("%f ", pM[i]);*/ /*}*/ /*Rprintf("\n");*/ /* int *pzero; pzero = (int *) malloc(sizeof(int)); *pzero = 0; */ int zero = 0; /* Rprintf("test1");*/ GetRNGstate(); /* Get .Random.seed from R */ if(*pisTwoMode){ Rprintf("Optimization of two-mode networks is not yet supported\n"); } else { critFun(pM, pnr, pnc, pnRel, pisTwoMode, pisSym, pdiag, pnColClus, pnRowClus, pnUnitsRowClu, pnUnitsColClu, prowParArr, pcolParArr, papproaches, pmaxBlockTypes, pnBlockTypeByBlock, pblocks, pIM, pEM, pEarr, perr, &zero, prowCluChange, pcolCluChange, psameIM, pregFun, phomFun, pusePreSpec, ppreSpecM, pcombWeights); /*Rprintf("Initial error = %.2f\n", *perr);*/ /* prepare temoprary objects - start*/ /* best result - start*/ /* partition*/ int *pbestrowParArr; int *pbestnUnitsRowClu; pbestnUnitsRowClu = (int *) malloc((*pnRowClus)*sizeof(int)); pbestrowParArr = (int *) malloc((*pnRowClus)*(*pnc)*sizeof(int)); for(int i=0;i<*pnRowClus;i++){ pbestnUnitsRowClu[i] = pnUnitsRowClu[i]; } for(int i=0;i<((*pnRowClus)*(*pnc));i++){ pbestrowParArr[i] = prowParArr[i]; } /* image matrix */ int *pbestIM; pbestIM = (int *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(int)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pbestIM[i] = pIM[i]; } /* number of block types by block - not needed int *pbestnBlockTypeByBlock; pbestnBlockTypeByBlock = (int *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(int)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pbestnBlockTypeByBlock[i] = pnBlockTypeByBlock[i]; } */ /* error matrix */ double *pbestEM; pbestEM = (double *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(double)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pbestEM[i] = pEM[i]; } /* error array by block types*/ double *pbestEarr; pbestEarr = (double *) malloc((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(double)); for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pbestEarr[i] = pEarr[i]; } double *pbesterr; pbesterr = (double *) malloc(sizeof(double)); *pbesterr = *perr; /* best result - end*/ /* temp result - start*/ /* partition*/ int *ptemprowParArr; int *ptempnUnitsRowClu; ptempnUnitsRowClu = (int *) malloc((*pnRowClus)*sizeof(int)); ptemprowParArr = (int *) malloc((*pnRowClus)*(*pnc)*sizeof(int)); for(int i=0;i<*pnRowClus;i++){ ptempnUnitsRowClu[i] = pnUnitsRowClu[i]; } for(int i=0;i<((*pnRowClus)*(*pnc));i++){ ptemprowParArr[i] = prowParArr[i]; } /* image matrix */ int *ptempIM; ptempIM = (int *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(int)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempIM[i] = pIM[i]; } /* number of block types by block - not needed int *ptempnBlockTypeByBlock; ptempnBlockTypeByBlock = (int *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(int)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempnBlockTypeByBlock[i] = pnBlockTypeByBlock[i]; } */ /* error matrix */ double *ptempEM; ptempEM = (double *) malloc((*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(double)); for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEM[i] = pEM[i]; } /* error array by block types*/ double *ptempEarr; ptempEarr = (double *) malloc((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus)*sizeof(double)); for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEarr[i] = pEarr[i]; } double *ptemperr; ptemperr = (double *) malloc(sizeof(double)); *ptemperr = *perr; /* temp result - end*/ /* prepare temoprary objects - end*/ int improve=1; /*Rprintf("OK1\n");*/ /* loop until no impovement is found */ *pnIter=0; while(improve){ *pnIter = *pnIter + 1; /* copy temp results to permanent - start*/ /* partition*/ for(int i=0;i<*pnRowClus;i++){ pnUnitsRowClu[i] = ptempnUnitsRowClu[i]; } for(int i=0;i<((*pnRowClus)*(*pnc));i++){ prowParArr[i] = ptemprowParArr[i]; } /* image matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pIM[i] = ptempIM[i]; } /* error matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pEM[i] = ptempEM[i]; } /* error array by block types*/ for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ pEarr[i] = ptempEarr[i]; } *perr = *ptemperr; /* copy temp results to permanent - end*/ improve=0; *psameErr = 1; /* to make the order of evaluation random - start */ /* randomize(); does not work */ int rnd; int rndClusters[*pnRowClus]; for(int i=0;i<*pnRowClus;i++){ rndClusters[i]=i; } /* to make the order of evaluation random - end */ int iClu, iClu2, iUnit, iUnit2; /* a loop over all clusters - random order */ for(int iRndClu=0;iRndClu<*pnRowClus;iRndClu++){ /* Rprintf("Start loop cluster 1\n"); */ /* to make the order of evaluation random - start*/ rnd=randomInt(*pnRowClus-iRndClu); iClu=rndClusters[rnd]; prowCluChange[0]=iClu; rndClusters[rnd]=rndClusters[*pnRowClus-iRndClu-1]; /* to make the order of evaluation random - end*/ /* a loop over all units inside clusters*/ /* to make the order of evaluation random - start*/ int rndUnitsInClu[pnUnitsRowClu[iClu]]; for(int i=0;iiClu){ rndClusters2[i-1]=i; } } /*Rprintf("OK 1.04\n");*/ /* to make the order of evaluation random - end*/ /* a loop over all other clusters - random order */ for(int iRndClu2=0;iRndClu2<(*pnRowClus-1);iRndClu2++){ /*Rprintf("Start loop cluster 2\n");*/ /* to make the order of evaluation random - start*/ rnd=randomInt(*pnRowClus - 1 - iRndClu2); /*Rprintf("rnd = %i, *pnRowClus - 1 - iRndClu2= %i\n", rnd, *pnRowClus - 1 - iRndClu2); */ iClu2=rndClusters2[rnd]; prowCluChange[1]=iClu2; rndClusters2[rnd]=rndClusters2[*pnRowClus - 2 - iRndClu2]; /*Rprintf("rndClusters2[rnd] = %i\n", rndClusters2[rnd]);*/ if (!pexchageClusters[iClu*(*pnRowClus)+iClu2]){ continue; } /* to make the order of evaluation random - end*/ if((pnUnitsRowClu[iClu]>(*pminUnitsRowCluster))&&(pnUnitsRowClu[iClu2]<(*pmaxUnitsRowCluster))){ /*Rprintf("OK1.1\n");*/ /* move unit to another cluster */ ptemprowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]]=ptemprowParArr[iClu*(*pnr)+iUnit]; /*Rprintf("OK1.2\n");*/ ptempnUnitsRowClu[iClu2]++; /* this line must be after the above line */ /*Rprintf("OK1.3\n");*/ ptempnUnitsRowClu[iClu]--; /* this line must be before the line below */ /*Rprintf("OK1.4\n");*/ ptemprowParArr[iClu*(*pnr)+iUnit]=ptemprowParArr[iClu*(*pnr)+ptempnUnitsRowClu[iClu]]; /*Rprintf("iClu = %i, iClu2= %i, iUnit=%i\n", iClu, iClu2, iUnit);*/ /*Rprintf("nClu = %i, nCluOld= %i, nClu2 = %i, nCluOld2= %i\n", ptempnUnitsRowClu[iClu], pnUnitsRowClu[iClu], ptempnUnitsRowClu[iClu2], pnUnitsRowClu[iClu2]); */ /*for(int i1=0;i1<(*pnRowClus);i1++){ Rprintf("cluster = %i, unitsCluster= %i: ", i1, ptempnUnitsRowClu[i1]); for(int i2=0;i2<(ptempnUnitsRowClu[i1]);i2++){ Rprintf("%i ", ptemprowParArr[i1*(*pnr)+i2]); } Rprintf("\n"); }*/ /*Rprintf("OK2\n");*/ /* here the new partition is evaluated*/ critFun(pM, pnr, pnc, pnRel, pisTwoMode, pisSym, pdiag, pnColClus, pnRowClus, ptempnUnitsRowClu, ptempnUnitsRowClu, ptemprowParArr, ptemprowParArr, papproaches, pmaxBlockTypes, pnBlockTypeByBlock, pblocks, ptempIM, ptempEM, ptempEarr, ptemperr, pjustChange, prowCluChange, prowCluChange, psameIM, pregFun, phomFun, pusePreSpec, ppreSpecM, pcombWeights); /*Rprintf("Error after move = %.2f\n", *ptemperr);*/ /*Rprintf("OK3\n");*/ if (*ptemperr< (*perr)) { /*Rprintf("OK4a\n");*/ /*Rprintf("################################################################\n"); */ improve=1; break; } else { if (*ptemperr == (*perr)) {*psameErr += 1;} /*Rprintf("OK4b\n");*/ /* undo if the improvement was not found */ ptempnUnitsRowClu[iClu2]--; /* this line must be before the line below */ ptemprowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]] = prowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]]; ptemprowParArr[iClu*(*pnr)+iUnit]=prowParArr[iClu*(*pnr)+iUnit]; ptempnUnitsRowClu[iClu]++; /* this line must be after the above line */ /* temp values must be set to equal permament to be updated as needed if justChange is used*/ if(*pjustChange){ /* temp result - copy "regular" to temp - start*/ /* image matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempIM[i] = pIM[i]; } /* error matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEM[i] = pEM[i]; } /* error array by block types*/ for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEarr[i] = pEarr[i]; } /* temp result - end*/ } } /*Rprintf("OK5\n");*/ } /*check the exchange of units only if iClu1 < iClu2 to avoid repeating the same move */ if(iClu < iClu2){ /* to make the order of evaluation random - start*/ int rndUnitsInClu2[pnUnitsRowClu[iClu2]]; for(int i=0;iiClu){ rndClusters2[i-1]=i; } } */ /*Rprintf("OK 1.04\n");*/ /* to make the order of evaluation random - end*/ /* a loop over all other clusters - random order */ /* for(int iRndClu2=0;iRndClu2<(*pnRowClus-1);iRndClu2++){ */ for(int iClu2=0;iClu2<(*pnRowClus);iClu2++){ if(iClu==iClu2) continue; /*Rprintf("Start loop cluster 2\n");*/ /* to make the order of evaluation random - start*/ /* rnd=randomInt(*pnRowClus - 1 - iRndClu2); */ /*Rprintf("rnd = %i, *pnRowClus - 1 - iRndClu2= %i\n", rnd, *pnRowClus - 1 - iRndClu2); */ /* iClu2=rndClusters2[rnd]; rndClusters2[rnd]=rndClusters2[*pnRowClus - 2 - iRndClu2]; */ /*Rprintf("rndClusters2[rnd] = %i\n", rndClusters2[rnd]);*/ prowCluChange[1]=iClu2; /*Rprintf("Test exchange - start\n");*/ if (!pexchageClusters[iClu*(*pnRowClus)+iClu2]){ continue; } /*Rprintf("Test exchange - end\n");*/ /* to make the order of evaluation random - end*/ if((pnUnitsRowClu[iClu]>(*pminUnitsRowCluster))&&(pnUnitsRowClu[iClu2]<(*pmaxUnitsRowCluster))){ /*Rprintf("OK1.1\n");*/ /* move unit to another cluster */ ptemprowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]]=ptemprowParArr[iClu*(*pnr)+iUnit]; /*Rprintf("OK1.2\n");*/ ptempnUnitsRowClu[iClu2]++; /* this line must be after the above line */ /*Rprintf("OK1.3\n");*/ ptempnUnitsRowClu[iClu]--; /* this line must be before the line below */ /*Rprintf("OK1.4\n");*/ ptemprowParArr[iClu*(*pnr)+iUnit]=ptemprowParArr[iClu*(*pnr)+ptempnUnitsRowClu[iClu]]; /*Rprintf("iClu = %i, iClu2= %i, iUnit=%i\n", iClu, iClu2, iUnit);*/ /*Rprintf("nClu = %i, nCluOld= %i, nClu2 = %i, nCluOld2= %i\n", ptempnUnitsRowClu[iClu], pnUnitsRowClu[iClu], ptempnUnitsRowClu[iClu2], pnUnitsRowClu[iClu2]);*/ /*Rprintf("prowCluChange: %i, %i \n", prowCluChange[0], prowCluChange[1]);*/ /*for(int i1=0;i1<(*pnRowClus);i1++){*/ /* Rprintf("cluster = %i, unitsCluster= %i: ", i1, ptempnUnitsRowClu[i1]);*/ /* for(int i2=0;i2<(ptempnUnitsRowClu[i1]);i2++){*/ /* Rprintf("%i ", ptemprowParArr[i1*(*pnr)+i2]);*/ /* }*/ /* Rprintf("\n");*/ /*}*/ /*Rprintf("OK2\n");*/ /* here the new partition is evaluated*/ critFun(pM, pnr, pnc, pnRel, pisTwoMode, pisSym, pdiag, pnColClus, pnRowClus, ptempnUnitsRowClu, ptempnUnitsRowClu, ptemprowParArr, ptemprowParArr, papproaches, pmaxBlockTypes, pnBlockTypeByBlock, pblocks, ptempIM, ptempEM, ptempEarr, ptemperr, pjustChange, prowCluChange, prowCluChange, psameIM, pregFun, phomFun, pusePreSpec, ppreSpecM, pcombWeights); /*Rprintf("Error after move = %.2f\n", *ptemperr);*/ /*Rprintf("Error array and blocks:\n");*/ /*int ind2d, ind3d, ind4d;*/ /*for(int iColClu=0;iColClu<*pnColClus;iColClu++){*/ /* Rprintf("\niColClu = %i\n", iColClu);*/ /* for(int iRowClu=0;iRowClu<*pnRowClus;iRowClu++){*/ /* Rprintf("iRowClu = %i\n", iRowClu);*/ /* ind2d=iColClu*(*pnRowClus) + iRowClu;*/ /* for(int iRel=0; iRel<(*pnRel);iRel++){*/ /* Rprintf("iRel = %i:\n", iRel);*/ /* ind3d= (ind2d*(*pnRel)+ iRel);*/ /* for(int iBlockType=0;iBlockType<(pnBlockTypeByBlock[ind3d]);iBlockType++){*/ /* ind4d=ind3d*(*pmaxBlockTypes)+iBlockType;*/ /* Rprintf("Blocktype = %i, err = %.5f \n", pblocks[ind4d], ptempEarr[ind4d]);*/ /* }*/ /* }*/ /* }*/ /*}*/ /*Rprintf("OK3\n");*/ if (*ptemperr< (*pbesterr)) { /* Rprintf("Error after move = %.2f\n", *ptemperr);*/ *psameErr=1; *pbesterr= *ptemperr; updateResults(pnc, pnRel, pnColClus, pnRowClus, pmaxBlockTypes, ptempnUnitsRowClu, ptemprowParArr, ptempIM, ptempEM, ptempEarr, ptemperr, pbestnUnitsRowClu, pbestrowParArr, pbestIM, pbestEM, pbestEarr, pbesterr); parArr2Vec(pnc, pnRowClus, ptempnUnitsRowClu, ptemprowParArr, pbestrowPar); for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[i] = pbestrowPar[i]; } /* Zdajle poskuam narediti tako, da bo program el ez vsa mona razbitja in shranil doloeno tevilo najboljih Torej da se zanka ne bo zakljuila, ko se bo nalo prvo bolje razbitje Pazi da bo popravil spremembe, tako tko spodaj, na zatku iteracije pa jih je potrebno ponovno udejanjiti!!! Mogoe se da kako bolje to narediti!!! */ /*Rprintf("OK4a\n");*/ /*Rprintf("################################################################\n");*/ improve=1; } else { if (*ptemperr == (*pbesterr)) { *psameErr += 1; int randTemp=randomInt(*psameErr); /* Rprintf("Error after move = %.2f\n", *ptemperr);*/ /* Rprintf("rndUpdate = %i\n", randTemp);*/ if(randTemp == 0){ updateResults(pnc, pnRel, pnColClus, pnRowClus, pmaxBlockTypes, ptempnUnitsRowClu, ptemprowParArr, ptempIM, ptempEM, ptempEarr, ptemperr, pbestnUnitsRowClu, pbestrowParArr, pbestIM, pbestEM, pbestEarr, pbesterr); parArr2Vec(pnc, pnRowClus, ptempnUnitsRowClu, ptemprowParArr, pbestrowPar); if(*psameErr <= *pmaxPar){ for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[((*psameErr)-1)*(*pnc)+i] = pbestrowPar[i]; } }else{ rnd=randomInt(*psameErr); /* Rprintf("rndOverwrite = %i\n", rnd);*/ if (rnd< *pmaxPar){ for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[rnd*(*pnc)+i] = pbestrowPar[i]; } } } } else{ parArr2Vec(pnc, pnRowClus, ptempnUnitsRowClu, ptemprowParArr, ptemprowPar); if(*psameErr <= *pmaxPar){ for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[((*psameErr)-1)*(*pnc)+i] = ptemprowPar[i]; } }else{ rnd=randomInt(*psameErr); /* Rprintf("Error after move = %.2f\n", *ptemperr);*/ /* Rprintf("rndOverwrite = %i\n", rnd);*/ if (rnd< *pmaxPar){ for(int i=0;i<(*pnc);i++){ pbestRowParMatrix[rnd*(*pnc)+i] = ptemprowPar[i]; } } } } } } /*Rprintf("OK4b\n");*/ /* undo change found */ ptempnUnitsRowClu[iClu2]--; /* this line must be before the line below */ ptemprowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]] = prowParArr[iClu2*(*pnr)+ptempnUnitsRowClu[iClu2]]; ptemprowParArr[iClu*(*pnr)+iUnit]=prowParArr[iClu*(*pnr)+iUnit]; ptempnUnitsRowClu[iClu]++; /* this line must be after the above line */ /* temp values must be set to equal permament to be updated as needed if justChange is used*/ if(*pjustChange){ /* temp result - copy "regular" to temp - start*/ /* image matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempIM[i] = pIM[i]; } /* error matrix */ for(int i=0;i<((*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEM[i] = pEM[i]; } /* error array by block types*/ for(int i=0;i<((*pmaxBlockTypes)*(*pnRel)*(*pnRowClus)*(*pnColClus));i++){ ptempEarr[i] = pEarr[i]; } /* temp result - end*/ } /*Rprintf("OK5\n");*/ } /*check the exchange of units only if iClu1 < iClu2 to avoid repeating the same move */ if(iClu < iClu2){ /* to make the order of evaluation random - start*/ /* int rndUnitsInClu2[pnUnitsRowClu[iClu2]]; for(int i=0;i0],1-apply(M,2,sum)[apply(M,2,sum)>0])^2) } side<-1 i=0 tmpM<-list(M,M) while(diffM(M)>eps){ i=i+1 sums<-apply(M, side, sum) sums[sums==0]<-1 M<-sweep(M, side, sums,FUN="/") if(max(c(M-tmpM[[side]])^2)=maxiter){ warning("Maximum number of itrerations (",maxiter,") reached, convergence not achieved.\n") break } } M<-(tmpM[[1]]+tmpM[[2]])/2 return(M) }blockmodeling/R/critFunC.R0000644000176200001440000010312314112157172015125 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 blocktypes. For multi-relational networks, it can be a list of such vectors. For \code{approaches = "bin"} or \code{approaches = "val"}, at least two should be selected. Possible values are:\cr #' \code{"nul"} - null or empty block\cr #' \code{"com"} - complete block\cr #' \code{"rdo"}, \code{"cdo"} - row and column-dominant blocks (binary and valued approach only)\cr #' \code{"reg"} - (f-)regular block\cr #' \code{"rre"}, \code{"cre"} - row and column-(f-)regular blocks\cr #' \code{"rfn"}, \code{"cfn"} - row and column-dominant blocks (binary, valued only)\cr #' \code{"den"} - density block (binary approach only)\cr #' \code{"avg"} - average block (valued approach only)\cr #' \code{"dnc"} - do not care block - the error is always zero\cr #' The ordering is important, since if several block types have identical error, the first on the list is selected.\cr\cr #' A pre-specified blockmodel.\cr #' An array with 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 symetric. #' @param diag Should the special stauts of diagonal be acknowladged. The default value is set to \code{1}. #' @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 damand 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 homogenity blockmodeling two vairability criteria can be used: \code{"ss"} - sum of squares (set by default) and \code{"ad"} - #' absolute deviations. #' @param usePreSpecM Specifiying weather a pre-specified value should be used when computing inconsistency. #' @param preSpecM Suficient value for individual cells for valued approach. Can be a number or a character string giving the name of a function. Set to \code{"max"} for implicit approach. For multi-relational networks, it can be a vector of such values. In case ob binary blockmodeling this argument is a threshold used for binerizing the network. Therefore all values with values lower than \code{preSpecM} are recoded into 0s, all other into 1s. For multi-relational networks, it can be a vector of such values. In case of pre-specified blockmodeling, it can have the same dimensions as \code{blocks}. #' @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 accros block types (see \code{blocks} above). It must be suplied in form of a named vetor, where the names are one or all allowed block types from \code{blocks}. If only some block types are specified, the other have a default weight of 1. The default value is set to \code{1}. #' @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. #' #' #' #' @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){ if(save.initial.param){ initial.param<-list(initial.param=tryCatch(lapply(as.list(sys.frame(sys.nframe())),eval),error=function(...)return("error"))) #saves the inital parameters }else initial.param<-NULL if(length(dim(M))==2) M<-array(M,dim=c(dim(M),length(approaches))) #M[,,approaches=="bin"]<-(M[,,approaches=="bin"]>0)*1 dM<-dim(M) if(is.null(isTwoMode)) isTwoMode<-is.list(clu) if(!is.list(clu))clu<-list(clu,clu) orgClu<-clu clu<-lapply(clu,function(x)as.integer(as.factor(x))) nUnitsInRCclu<-lapply(clu,function(x)as.integer(table(x))) nRCclu<-sapply(nUnitsInRCclu,length) # if(is.null(nMode)) nMode<-ifelse(is.list(clu),length(clu),1) # if(nMode>1){ # tmNclu<-sapply(clu,max) # for(iMode in 2:nMode){ # clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) # } # clu<-unlist(clu) # } rowParArr<-matrix(as.integer(0),nrow=dM[1],ncol=nRCclu[1]) for(i in 1:nRCclu[[1]]){ rowParArr[1:nUnitsInRCclu[[1]][i],i]<-as.integer(which(clu[[1]]==i)-1) } colParArr<-matrix(as.integer(0),nrow=dM[2],ncol=nRCclu[2]) for(i in 1:nRCclu[[2]]){ colParArr[1:nUnitsInRCclu[[2]][i],i]<-as.integer(which(clu[[2]]==i)-1) } if(is.null(isSym)){ isSym<-integer(dM[3]) if(isTwoMode) { isSym[]<-FALSE } else { for(i in 1:dM[3]) isSym[i]<-all(M[,,i]==t(M[,,i])) } } else if(length(isSym)==1) isSym<-rep(isSym, dM[3]) if(isTwoMode)diag<-FALSE if(length(diag)!=dM[3]) diag<-rep(diag[1], dM[3]) if(length(approaches)!=dM[3]&&(length(approaches)==1)) approaches<-rep(approaches[1], dM[3]) if(is.list(blocks)){ if(length(blocks)!=dM[3]) stop("the number of relations implied by 'blocks' and by 'M' does not match") maxBlockTypes<- max(sapply(blocks,length)) blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) for(i in 1:dM[3]){ nBT<-length(blocks[[i]]) blocksArr[1:nBT,i,,]<-array(blocks[[i]],dim=c(nBT,nRCclu)) } blocks <- blocksArr } else if(is.vector(blocks)){ maxBlockTypes<-length(blocks) blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) blocksArr[1:length(blocks),,,]<-blocks blocks <- blocksArr } else if(!is.array(blocks)){ stop("'blocks' argument should be a vector, a list or an array with appropriate dimmensions") }else { if(length(dim(blocks))==4){ maxBlockTypes<-dim(blocks)[1] if(any(dim(blocks)!=c(maxBlockTypes,dM[3],nRCclu))) stop("array ('blocks' argument) has a wrong dimensions of dimmensions") } else if(length(dim(blocks))==3){ maxBlockTypes<-dim(blocks)[1] blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) for(i in 1:dM[3]){ blocksArr[,i,,]<-blocks } blocks <- blocksArr } else if(length(dim(blocks))==2){ maxBlockTypes<-1 blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) for(i in 1:dM[3]){ blocksArr[1,i,,]<-blocks } blocks <- blocksArr } else stop("array ('blocks' argument) has a wrong number of dimmensions") } dB<-dim(blocks) if(dB[2]!=dM[3])stop("the number of relations implied by 'blocks' and by 'M' does not match") if(!all(dB[3:4]==nRCclu))stop("number of clusters implied by 'blocks' and by 'clu' does not match") nBlockTypeByBlock<-apply(!is.na(blocks),c(2,3,4),sum) blocks[blocks=="null"]<-"nul" blocks[blocks=="den"]<-"avg" if(is.null(IM)){ IM<-array(as.integer(99),dim=dB[2:4]) }else if (length(dim(IM))==2){ IM<-array(as.integer(factor(IM,levels=cStatus$blockTypes))-as.integer(1),dim=c(dM[3],nRCclu)) }else{ IM<-array(as.integer(factor(IM,levels=cStatus$blockTypes))-as.integer(1),dim=dim(IM)) } if(is.null(EM)){ EM<-array(as.double(Inf),dim=dB[2:4]) } else EM<-array(as.double(EM),dim=dim(EM)) if(is.null(Earr)){ Earr<-array(as.double(Inf),dim=dB) }else Earr<-array(as.double(Earr),dim=dim(Earr)) if(length(homFun)==1 & dM[3]>1) homFun<-rep(homFun,dM[3]) homFun[approaches=="ss"]<-"ss" homFun[approaches=="ad"]<-"ad" approaches[approaches%in%c("ss","ad")]<-"hom" homFun<-as.integer(factor(homFun,levels=cStatus$homFuns))-as.integer(1) regFun<-as.integer(factor(regFun,levels=cStatus$regFuns))-as.integer(1) if(is.vector(regFun)){ if(length(regFun)==1){ regFun <- array(as.integer(regFun),dim=dB) }else if (dB[2]==1){ if(length(regFun)==dB[1]){ regFunArr <- array(as.integer(NA),dim=dB) regFunArr[,,,]<-regFun regFun<-regFunArr } else stop("'regFun' is a vector of unapropriate length") } else if(length(regFun)==dB[2]){ regFunArr <- array(as.integer(NA),dim=dB) regFunArr[,,,]<-regFun regFun<-regFunArr } else stop("'regFun' is a vector of unapropriate length") } else if(is.array(regFun)){ if(dim(regFun)!=dB){ stop("'regFun' is an array - dimensions of 'regFun' and 'blocks' do not match") } } else stop("'regFun' is neither a vector or an array") preSpecM<-formatPreSpecM(preSpecMorg=preSpecM,dB=dB,blocks=blocks) usePreSpecM<-formatUsePreSpecM(usePreSpecMorg=usePreSpecM,preSpecM=preSpecM,dB=dB,blocks=blocks) if(any(approaches=="bin") && (!all(M[,,approaches=="bin"] %in% c(0,1)))){ for(i in 1:length(approaches)){ if(approaches[i]=="bin"){ if(!all(M[,,i] %in% c(0,1))){ tmpPreSpecM<-preSpecM[,i,,] if(all(is.na(tmpPreSpecM))){ M[,,i]<-(M[,,i]>0)*1 } else if(all(tmpPreSpecM==tmpPreSpecM[1,1,1])){ M[,,i]<-(M[,,i]>=tmpPreSpecM[1,1,1])*1 } else stop("Relation ",i," is not binary but suplied to binary blockmodeling without suitable value in 'preSpecM'!",sep="") } } } } approaches <- as.integer(factor(approaches,levels=cStatus$implementedApproaches))-as.integer(1) combWeights<-computeCombWeights(combWeights, dB, blocks, relWeights, posWeights, blockTypeWeights) blocks<-array(as.integer(factor(blocks,levels=cStatus$blockTypes)),dim=dim(blocks))-as.integer(1) M<-apply(M,c(2,3),as.double) resC<-.C("critFun", M=M, nr=dM[1], nc=dM[2], nRel=dM[3], isTwoMode=as.integer(isTwoMode), isSym=as.integer(isSym), diag=as.integer(diag), nColClus=nRCclu[2], nRowClus=nRCclu[1], nUnitsRowClu=nUnitsInRCclu[[1]], nUnitsColClu=nUnitsInRCclu[[2]], rowParArr=rowParArr, colParArr=colParArr, approaches=approaches, maxBlockTypes=as.integer(maxBlockTypes), nBlockTypeByBlock=array(as.integer(nBlockTypeByBlock),dim=dim(nBlockTypeByBlock)), blocks=blocks, IM=IM, EM=EM, Earr=Earr, err=sum(EM), justChange=as.integer(justChange), rowCluChange=as.integer(rowCluChange), colCluChange=as.integer(colCluChange), sameIM=as.integer(sameIM), regFun=regFun, homFun=homFun, usePreSpec=usePreSpecM, preSpecM=preSpecM,combWeights=combWeights,NAOK=TRUE) res<-c(list(M=M), resC[c("err","EM","Earr")], list(IM=IMaddNames(resC$IM)), list(clu=orgClu), initial.param, list(call=match.call()), if(returnEnv)list(env= environment()) else NULL) class(res)<-"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. #' #' @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",save.initial.param=TRUE){ if(save.initial.param){ initial.param<-list(initial.param=tryCatch(lapply(as.list(sys.frame(sys.nframe())),eval),error=function(...)return("error"))) #saves the inital parameters }else initial.param<-NULL if(length(dim(M))==2) M<-array(M,dim=c(dim(M),length(approaches))) dM<-dim(M) if(is.null(nMode)) nMode<-ifelse(is.list(clu),length(clu),1) if(nMode>1){ tmN<-sapply(clu,length) clu<-lapply(clu,function(x)as.integer(as.factor(x))) tmNclu<-sapply(clu,max) for(iMode in 2:nMode){ clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) } clu<-unlist(clu) if(dM[1]!=length(clu)|dM[2]!=length(clu)){ warning("Two (and more) mode networks implemented through one mode networks!\nOnly partition, network and blocks arguments are converted if needed!\nIf usePrespecVal and similar arguments are arrays they must be in appropriate format - one mode network with two-mode network in upper right quadrant") #currently two mode networks are treated as a special case of one mode networks where 3 "quadrants" of the network are filled with zeros oldM<-M oldDM<-dim(oldM) nUnitsTmp<-length(clu) M<-array(0,dim=c(nUnitsTmp,nUnitsTmp,length(approaches))) M[1:oldDM[1],((oldDM[1]+1):nUnitsTmp),]<-oldM dM<-dim(M) } } if(!is.list(clu))clu<-list(clu,clu) clu<-lapply(clu,function(x)as.integer(as.factor(x))-as.integer(1)) nUnitsInRCclu<-lapply(clu,function(x)as.integer(table(x))) nRCclu<-sapply(nUnitsInRCclu,length) rowParArr<-matrix(as.integer(0),nrow=dM[1],ncol=nRCclu[1]) for(i in 1:nRCclu[1]){ rowParArr[1:nUnitsInRCclu[[1]][i],i]<-as.integer(which(clu[[1]]==(i-1))-1) } colParArr<-matrix(as.integer(0),nrow=dM[2],ncol=nRCclu[2]) for(i in 1:nRCclu[2]){ colParArr[1:nUnitsInRCclu[[2]][i],i]<-as.integer(which(clu[[2]]==(i-1))-1) } if(exchageClusters=="all"){ if(nMode>1){ exchageClusters=matrix(as.integer(0),nrow=nRCclu[1],ncol=nRCclu[2]) tmp<-c(0,tmNclu) for(imodeNclu in seq_along(tmNclu)){ tmpInd<-(sum(tmp[1:imodeNclu])+1):sum(tmNclu[1:imodeNclu]) exchageClusters[tmpInd,tmpInd]=as.integer(1) } } else{ exchageClusters=matrix(as.integer(1),nrow=nRCclu[1],ncol=nRCclu[2]) } } if(is.null(isSym)){ isSym<-integer(dM[3]) for(i in 1:dM[3]) isSym[i]<-all(M[,,i]==t(M[,,i])) } else if(length(isSym)==1) isSym<-rep(isSym, dM[3]) #if(isTwoMode)diag<-FALSE #not needed as two mode netowrks are implemented through one-mode networks if(length(diag)!=dM[3]) diag<-rep(diag[1], dM[3]) if(length(approaches)!=dM[3]&&(length(approaches)==1)) approaches<-rep(approaches[1], dM[3]) if(is.list(blocks)){ if(length(blocks)!=dM[3]) stop("the number of relations implied by 'blocks' and by 'M' does not match") maxBlockTypes<- max(sapply(blocks,length)) blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) for(i in 1:dM[3]){ nBT<-length(blocks[[i]]) blocksArr[1:nBT,i,,]<-array(blocks[[i]],dim=c(nBT,nRCclu)) } blocks <- blocksArr } else if(is.vector(blocks)){ maxBlockTypes<-length(blocks) blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) blocksArr[1:length(blocks),,,]<-blocks blocks <- blocksArr } else if(!is.array(blocks)){ stop("'blocks' argument should be a vector, a list or an array with appropriate dimmensions") }else { if(length(dim(blocks))==4){ maxBlockTypes<-dim(blocks)[1] if(any(dim(blocks)!=c(maxBlockTypes,dM[3],nRCclu))){ if(nMode==2){ oldBlocks<-blocks blocks<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) blocks[,,1:tmNclu[1],(tmNclu[1]+1):sum(tmNclu)]<-oldBlocks blocks[1,,(tmNclu[1]+1):sum(tmNclu),]<-"dnc" blocks[1,,1:tmNclu[1],1:tmNclu[1]]<-"dnc" if(any(dim(blocks)!=c(maxBlockTypes,dM[3],nRCclu))) stop("array ('blocks' argument) has a wrong dimensions of dimensions") } else stop("array ('blocks' argument) has a wrong dimensions of dimensions") } } else if(length(dim(blocks))==3){ maxBlockTypes<-dim(blocks)[1] blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) if(nMode==2){ for(i in 1:dM[3]){ blocksArr[,i,1:tmNclu[1],(tmNclu[1]+1):sum(tmNclu)]<-blocks } } else { for(i in 1:dM[3]){ blocksArr[,i,,]<-blocks } } blocks <- blocksArr if(nMode==2){ blocks[1,,(tmNclu[1]+1):sum(tmNclu),]<-"dnc" blocks[1,,1:tmNclu[1],1:tmNclu[1]]<-"dnc" } } else if(length(dim(blocks))==2){ maxBlockTypes<-1 blocksArr<-array(NA,dim=c(maxBlockTypes,dM[3],nRCclu)) if(nMode==2){ for(i in 1:dM[3]){ blocksArr[1,i,1:tmNclu[1],(tmNclu[1]+1):sum(tmNclu)]<-blocks } }else { for(i in 1:dM[3]){ blocksArr[1,i,,]<-blocks } } blocks<-blocksArr if(nMode==2){ blocks[1,,(tmNclu[1]+1):sum(tmNclu),]<-"dnc" blocks[1,,1:tmNclu[1],1:tmNclu[1]]<-"dnc" } } else stop("array ('blocks' argument) has a wrong number of dimmensions") } dB<-dim(blocks) if(dB[2]!=dM[3])stop("the number of relations implied by 'blocks' and by 'M' does not match") if(!all(dB[3:4]==nRCclu))stop("number of clusters implied by 'blocks' and by 'clu' does not match") nBlockTypeByBlock<-apply(!is.na(blocks),c(2,3,4),sum) blocks[blocks=="null"]<-"nul" blocks[blocks=="den"]<-"avg" if(is.null(IM)){ IM<-array(as.integer(99),dim=dB[2:4]) }else if (length(dim(IM))==2){ IM<-array(as.integer(factor(IM,levels=cStatus$blockTypes))-as.integer(1),dim=c(dM[3],nRCclu)) }else{ IM<-array(as.integer(factor(IM,levels=cStatus$blockTypes))-as.integer(1),dim=dim(IM)) } if(is.null(EM)){ EM<-array(as.double(Inf),dim=dB[2:4]) } else EM<-array(as.double(EM),dim=dim(EM)) if(is.null(Earr)){ Earr<-array(as.double(Inf),dim=dB) }else Earr<-array(as.double(Earr),dim=dim(Earr)) if(length(homFun)==1 & dM[3]>1) homFun<-rep(homFun,dM[3]) homFun[approaches=="ss"]<-"ss" homFun[approaches=="ad"]<-"ad" approaches[approaches%in%c("ss","ad")]<-"hom" homFun<-as.integer(factor(homFun,levels=cStatus$homFuns))-as.integer(1) regFun<-as.integer(factor(regFun,levels=cStatus$regFuns))-as.integer(1) if(is.vector(regFun)){ if(length(regFun)==1){ regFun <- array(as.integer(regFun),dim=dB) }else if (dB[2]==1){ if(length(regFun)==dB[1]){ regFunArr <- array(as.integer(NA),dim=dB) regFunArr[,,,]<-regFun regFun<-regFunArr } else stop("'regFun' is a vector of unapropriate length") } else if(length(regFun)==dB[2]){ regFunArr <- array(as.integer(NA),dim=dB) regFunArr[,,,]<-regFun regFun<-regFunArr } else stop("'regFun' is a vector of unapropriate length") } else if(is.array(regFun)){ if(dim(regFun)!=dB){ stop("'regFun' is an array - dimensions of 'regFun' and 'blocks' do not match") } } else stop("'regFun' is neither a vector or an array") preSpecM<-formatPreSpecM(preSpecMorg=preSpecM,dB=dB,blocks=blocks) usePreSpecM<-formatUsePreSpecM(usePreSpecMorg=usePreSpecM,preSpecM=preSpecM,dB=dB,blocks=blocks) if(any(approaches=="bin") && (!all(M[,,approaches=="bin"] %in% c(0,1)))){ for(i in 1:length(approaches)){ if(approaches[i]=="bin"){ if(!all(M[,,i] %in% c(0,1))){ tmpPreSpecM<-preSpecM[,i,,] if(all(is.na(tmpPreSpecM))){ M[,,i]<-(M[,,i]>0)*1 } else if(all(tmpPreSpecM==tmpPreSpecM[1,1,1])){ M[,,i]<-(M[,,i]>=tmpPreSpecM[1,1,1])*1 } else stop("Relation ",i," is not binary but suplied to binary blockmodeling without suitable value in 'preSpec'!",sep="") } } } } approaches <- as.integer(factor(approaches,levels=cStatus$implementedApproaches))-as.integer(1) M<-apply(M,c(2,3),as.double) combWeights<-computeCombWeights(combWeights, dB, blocks, relWeights, posWeights, blockTypeWeights) blocks<-array(as.integer(factor(blocks,levels=cStatus$blockTypes)),dim=dim(blocks))-as.integer(1) if(useMulti){ bestColParMatrix <- matrix(as.integer(NA),ncol=maxPar,nrow=dM[2]) bestRowParMatrix <- matrix(as.integer(NA),ncol=maxPar,nrow=dM[1]) resC<-.C("optParMulti", M=M, nr=dM[1], nc=dM[2], nRel=dM[3], isTwoMode= 0 #as.integer(isTwoMode) - two mode networks are currently implemented through onemode networks , isSym=as.integer(isSym), diag=as.integer(diag), nColClus=nRCclu[2], nRowClus=nRCclu[1], nUnitsRowClu=nUnitsInRCclu[[1]], nUnitsColClu=nUnitsInRCclu[[2]], rowPar=clu[[1]], colPar=clu[[2]], rowParArr=rowParArr, colParArr=colParArr, approaches=approaches, maxBlockTypes=as.integer(maxBlockTypes), nBlockTypeByBlock=array(as.integer(nBlockTypeByBlock),dim=dim(nBlockTypeByBlock)), blocks=blocks, IM=IM, EM=EM, Earr=Earr, err=sum(EM), justChange=as.integer(justChange), rowCluChange=integer(2), colCluChange=integer(2), sameIM=as.integer(sameIM), regFun=regFun, homFun=homFun, usePreSpec=usePreSpecM, preSpecM=preSpecM, minUnitsRowCluster = as.integer(minUnitsRowCluster), minUnitsColCluster = as.integer(minUnitsColCluster), maxUnitsRowCluster = as.integer(maxUnitsRowCluster), maxUnitsColCluster = as.integer(maxUnitsColCluster), sameErr=as.integer(0), nIter=as.integer(0),combWeights=combWeights, exchageClusters=exchageClusters, maxPar=as.integer(maxPar), bestColParMatrix=bestColParMatrix, bestRowParMatrix=bestRowParMatrix, NAOK=TRUE) clu<- resC$rowPar } else{ resC<-.C("optPar", M=M, nr=dM[1], nc=dM[2], nRel=dM[3], isTwoMode= 0 #as.integer(isTwoMode) - two mode networks are currently implemented through onemode networks , isSym=as.integer(isSym), diag=as.integer(diag), nColClus=nRCclu[2], nRowClus=nRCclu[1], nUnitsRowClu=nUnitsInRCclu[[1]], nUnitsColClu=nUnitsInRCclu[[2]], rowParArr=rowParArr, colParArr=colParArr, approaches=approaches, maxBlockTypes=as.integer(maxBlockTypes), nBlockTypeByBlock=array(as.integer(nBlockTypeByBlock),dim=dim(nBlockTypeByBlock)), blocks=blocks, IM=IM, EM=EM, Earr=Earr, err=sum(EM), justChange=as.integer(justChange), rowCluChange=integer(2), colCluChange=integer(2), sameIM=as.integer(sameIM), regFun=regFun, homFun=homFun, usePreSpec=usePreSpecM, preSpecM=preSpecM, minUnitsRowCluster = as.integer(minUnitsRowCluster), minUnitsColCluster = as.integer(minUnitsColCluster), maxUnitsRowCluster = as.integer(maxUnitsRowCluster), maxUnitsColCluster = as.integer(maxUnitsColCluster), sameErr=as.integer(0), nIter=as.integer(0),combWeights=combWeights,exchageClusters=exchageClusters, NAOK=TRUE) clu<- parArrOne2clu(nUnitsClu=resC$nUnitsRowClu, parArr=resC$rowParArr, nClus=resC$nRowClus) } # if(isTwoMode){ # not needed as two-mode networks are implementer through onemode networks # clu<- list( # parArrOne2clu(nUnitsClu=resC$nUnitsRowClu, parArr=resC$rowParArr, nClus=resC$nRowClus), # parArrOne2clu(nUnitsClu=resC$nUnitsColClu, parArr=resC$colParArr, nClus=resC$nColClus) # ) # } else { # This (under else) is moved up in to the if(useMulti), as it differs for both functions optPar C functions. Most likely, the below code could be used for both, but is not tested. # clu<- parArrOne2clu(nUnitsClu=resC$nUnitsRowClu, parArr=resC$rowParArr, nClus=resC$nRowClus) # } # this is new and experimental if(nMode>1){ clu<-split(clu, f = rep(1:length(tmN),times=tmN)) clu<-lapply(clu,function(x)as.integer(as.factor(x))) tmNclu<-sapply(clu,max) for(iMode in 2:nMode){ clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) } } else clu<-as.integer(as.factor(clu)) res<-c(list(M=M), resC[c("err","EM","Earr","sameErr")], list(IM=IMaddNames(resC$IM)), clu=list(clu), initial.param, list(call=match.call()),if(useMulti)list(bestRowParMatrix=bestRowParMatrix),list(resC=resC)) class(res)<-"optPar" return(res) } #' @useDynLib blockmodeling, .registration = TRUEblockmodeling/R/genRandomPar.R0000644000176200001440000001110214112157172015760 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.R0000644000176200001440000000005313654621042014676 0ustar liggesusers"useneg" <- function(x)ifelse(x<0,x,0) blockmodeling/R/sedist.R0000644000176200001440000003106013663721416014713 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(class(res)=="dist")attr(res,"Labels")<-rownames(M) if(is.matrix(res))dimnames(res)<-dimnames(M) return(res) } "sedistX" <- function( X, #a matrix composed of network and network transposed method="default", # the a method used to compute distances - any of the methods alloed by functions dist, cor or cov {all package::stats} or just "cor" or "cov" (given as character) fun="default", #which function should be used to comput distacnes (given as character), fun.on.rows="default", # for non-standard function - does it compute measure on rows (such as cor, cov,...) of the data matrix. # stats.dist.cor.cov=TRUE, #call "stats::dist", "stats::cor" or "stats::cov", not "dist", "cor" or "cov", if nonstandard functions are used, they should exemp the same arguments as those in package stats handle.interaction="switch", #how should the interaction between the vertices analysed be handled: # "switch" (the default) - assumes that when comparing units i and j, M[i,i] should be compared with M[j,j] and M[i,j] with M[j,i] # "switch1" - the same as above, only that each pair occurs only once # "switch2" - an alias for switch # "ignore" (diagonal) - Diagonal is ignored # "none" - the matrix is used "as is" use = "pairwise.complete.obs", #for use with methods "cor" and "cov", for other methods (the default option should be used if handle.interaction=="ignore"), "pairwise.complete.obs" are always used, if stats.dist.cor.cov=TRUE #p=2 ,#The power of the Minkowski distance in functin dist if stats.dist.cor.cov=TRUE ... #other argumets passed to fun ){ method<-match.arg(method, choices=c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski","pearson", "kendall", "spearman","dist","cor", "cov", "default")) handle.interaction<-match.arg(handle.interaction, choices=c("switch", "switch1", "switch2", "ignore", "none")) if(handle.interaction=="switch2")handle.interaction<-"switch" if(any(method=="default", fun=="default")){ if(all(method=="default", fun=="default")){ fun<-"dist" method<-"euclidean" } else if(fun=="default"){ if(method %in% c("pearson", "kendall", "spearman")) fun<-"cor" if(method %in% c("cor", "cov")){ fun<-method method<-"pearson" } if(method %in% c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski")) fun<-"dist" } else { if(fun %in% c("cor","cov")) method<-"pearson" if(fun=="dist") method<-"euclidean" } } if(handle.interaction=="ignore"&& fun %in% c("cor","cov") && use != "pairwise.complete.obs")warning("The option use='pairwise.complete.obs' should be used with handle.interaction=='ignore' && fun %in% c('cor','cov')") # if(fun %in% c("dist", "cor" or "cov") && stats.dist.cor.cov) fun<-paste("stats::",fun,sep="") if(fun.on.rows=="default") if(fun %in% c("cor","cov")){ fun.on.rows<-TRUE } else fun.on.rows<-FALSE n<-dim(X)[1] if(dim(X)[2]%%n!=0) stop("The columns must be a multiple of the rows") k<-dim(X)[2]/n if(fun %in% c("cor", "cov")) usearg<-list(use=use) else usearg<-NULL #usearg if(handle.interaction %in% c("switch","switch1")){ if(fun=="cor"){ cor1<-function(...)cor(...)[1,2] fun<-"cor1" } if(fun=="cov"){ cor1<-function(...)cov(...)[1,2] fun<-"cov1" } res<-matrix(NA,ncol=n,nrow=n) for(i in 2:n)for(j in seq(length=(i-1))){ jind<-seq(length=k*n) for(l in seq(0,k-1,by = 2)){ jind[l*n+i]<-j jind[l*n+j]<-i if((l+1)0) ind.stars<-which(substr(rLines,1,1)=="*") nstars<-length(ind.stars) stars<-rLines[ind.stars] stars<-trim.trailing(stars) rm(rLines) vnames1<-read.table(file=filename,skip=ind.stars[1],nrows=ind.stars[2]-ind.stars[1]-1,as.is =TRUE) vnames<-character(n) vnames[vnames1[,1]]<-vnames1[,2] if(all(is.na(vnames))){ vnames<-NULL } else vnames[is.na(vnames)]<-"" if(is.null(useSparseMatrix)){ useSparseMatrix<- n>=50 } if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::Matrix(0,nrow=n,ncol=n,sparse=TRUE) }else{ warning("Matrix package is not installed. Ordanary (dense) matrices will be used instead of sparse onse") M<-matrix(0,nrow=n,ncol=n) } }else{ M<-matrix(0,nrow=n,ncol=n) } if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::Matrix(0,nrow=n,ncol=n,sparse=TRUE) }else{ M<-matrix(0,nrow=n,ncol=n) warning("Matrix package is not installed. Ordanary (dense) matrices will be used instead of sparse onse") } } else{ M<-matrix(0,nrow=n,ncol=n) } for(i in 2:nstars){ nrows<-ifelse(i==nstars,-1,ind.stars[i+1]-ind.stars[i]-1) ties<-read.table(file=filename,skip=ind.stars[i],nrows=nrows) ncols<-dim(ties)[2] if(ncols==2){ ties<-cbind(ties,1) } else if(ncols>3){ ties<-ties[,1:3] } ties<-apply(ties,2,as.numeric) if(stars[i]=="*Arcs"|stars[i]=="*arcs"){ M[ties[,1:2]]<-ties[,3] } else if(stars[i]=="*Edges"|stars[i]=="*edges"){ M[ties[,1:2]]<-ties[,3] M[ties[,2:1]]<-ties[,3] } } dimnames(M)<-list(vnames,vnames) } else{ n12<-as.numeric(n[2]) n1<-as.numeric(n[3]) n2<-n12-n1 rLines<-readLines(con=filename) nl<-length(rLines) #ind.stars<-which(regexpr(pattern="*", text=rLines,fixed=TRUE)>0) ind.stars<-which(substr(rLines,1,1)=="*") nstars<-length(ind.stars) stars<-rLines[ind.stars] rm(rLines) vnames1<-read.table(file=filename,skip=ind.stars[1],nrows=ind.stars[2]-ind.stars[1]-1,as.is =TRUE) vnames<-character(n12) vnames[vnames1[,1]]<-vnames1[,2] if(all(is.na(vnames))){ vnames<-NULL } else vnames[is.na(vnames)]<-"" if(is.null(useSparseMatrix)){ useSparseMatrix<- n12>50 } if(useSparseMatrix){ if(requireNamespace("Matrix")){ M<-Matrix::Matrix(0,nrow=n12,ncol=n12,sparse=TRUE) }else{ warning("Matrix package is not installed. Ordanary (dense) matrices will be used instead of sparse onse") M<-matrix(0,nrow=n12,ncol=n12) } }else{ M<-matrix(0,nrow=n12,ncol=n12) } for(i in 2:nstars){ nrows<-ifelse(i==nstars,-1,ind.stars[i+1]-ind.stars[i]-1) ties<-read.table(file=filename,skip=ind.stars[i],nrows=nrows) ncols<-dim(ties)[2] if(ncols==2){ ties<-cbind(ties,1) } else if(ncols>3){ ties<-ties[,1:3] } ties<-apply(ties,2,as.numeric) M[ties[,1:2]]<-ties[,3] M[ties[,2:1]]<-ties[,3] } dimnames(M)<-list(vnames,vnames) M<-M[1:n1,(n1+1):n12] } return(M) } blockmodeling/R/REGE.FC.R0000644000176200001440000000420213663463024014425 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.R0000644000176200001440000004030713663463024015012 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.R0000644000176200001440000000303414076020070014610 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.R0000644000176200001440000001175114026573212016173 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.R0000644000176200001440000000103613663463024015560 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.R0000644000176200001440000007727114077547045015062 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. #' @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 "decearsing" (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.col The color of the line that separates the partitions. #' @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 collored, if \code{TRUE}, they are colored with colors of clusters as defined by palette. #' This can be aslo a vector of colors (or integers) for one-mode networks or a list of two such vectors for two-mode networks. #' @param \dots Aditional 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 possbily 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 ploted print.legend.val="out", #where should the values for the legend be printed: 'out' - outside the cells (bellow), 'in' - inside the cells, 'both' - inside and outside the cells print.digits.legend=2, #the number of digits that should appear in the legend print.digits.cells=2, #the number of digits that should appear in the cells (of the matrix and/or legend) print.cells.mf=NULL, #if not null, the above argument is igonred, the cell values are printed as the cell are multiplied by this factor and rounded outer.title=FALSE, #should the title be printed on the 'inner' or 'outer' plot, default is 'inner' if legend is ploted and 'outer' otherwise title.line= ifelse(outer.title,-1.5,7), #the line (from the top) where the title should be printed mar= c(0.5, 7, 8.5, 0)+0.1, #A numerical vector of the form 'c(bottom, left, top, right)' which gives the lines of margin to be specified on the four sides of the plot. The default is 'c(5, 4, 4, 2) + 0.1'. cex.val="default", #size of the values printed val.y.coor.cor = 0, #correction for centering the values in the sqares in y direction val.x.coor.cor = 0, #correction for centering the values in the sqares in x direction cex.legend=1, #size of the text in the legend, legend.title="Legend", #the title of the legend cex.axes="default", #size of the characters in axes, 'default' makes the cex so small that all categories can be printed print.axes.val=NULL, #should the axes values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL' print.x.axis.val=!is.null(colnames(M)), #should the x axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL' print.y.axis.val=!is.null(rownames(M)), #should the y axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL' x.axis.val.pos = 1.01, #y coordiante of the x axis values y.axis.val.pos = -0.01, #x coordiante of the y axis values cex.main=par()$cex.main, cex.lab=par()$cex.lab, yaxis.line=-1.5, #the position of the y axis (the argument 'line') xaxis.line=-1, #the position of the x axis (the argument 'line') legend.left=0.4,#how much left should the legend be from the matrix legend.up=0.03, #how much left should the legend be from the matrix legend.size=1/min(dim(M)), #relative legend size legend.text.hor.pos=0.5, #horizontal position of the legend text (bottom) - 0 = bottom, 0.5 = middle,... par.line.width = 3, #the width of the line that seperates the partitions par.line.col = "blue", #the color of the line that seperates the partitions IM.dens= NULL, IM= NULL, #Image used for ploting (shaded lines) wnet=NULL, #which net (if more) should be ploted - used if M is an array wIM=NULL, #which IM (if more) should be used for ploting (defualt = wnet) - used if IM is an array use.IM=length(dim(IM))==length(dim(M))|!is.null(wIM), #should IM be used for ploting? dens.leg=c(null=100, nul=100), blackdens=70, plotLines = FALSE, #Should the lines in the matrix be printed (best set to FALSE for larger networks) frameMatrix=TRUE, #Should the matrix be framed (if plotLines is FALSE) x0ParLine=-0.1, #x coordinates for lines between row clusters x1ParLine=1, #x coordinates for lines between row clusters y0ParLine=0, #y coordinates for lines between col clusters y1ParLine=1.1, #y coordinates for lines between col clusters colByUnits=NULL, #a vector (of 0s and 1s) indicating whether ties of a unit should be marked with a diferent (nonblack) color - only used for binary networks colByRow=NULL, #a vector (of 0s and 1s) indicating whether outgoing ties of a unit should be marked with a different (nonblack) color - only used for binary networks colByCol=NULL, #a vector (of 0s and 1s) indicating whether incoming ties of a unit should be marked with a different (nonblack) color - only used for binary networks mulCol = 2, joinColOperator = "+", colTies=FALSE, maxValPlot=NULL, # maximal value used for determining the color of cells in the plot. This value and all higher (in absolute terms) will produce a pure black/red color printMultipliedMessage = TRUE, # shold mutiplication message be printed when values were the printed tie values are multiplied replaceNAdiagWith0=TRUE, #Should the diagonal with only NAs be replace by 0s? colLabels=FALSE, # Should the labels of units be colored. If FALSE, these are not collored, if TRUE, they are colored with colors of clusters as defined by palette. This can be aslo a vector of colors (or integers) for one-mode networks or a list of two such vectors for two-mode networks. ... #aditional arguments to plot.default ){ old.mar<-par("mar") if(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 ploted print.legend.val=print.legend.val, #where should the values for the legend be printed: 'out' - outside the cells (bellow), 'in' - inside the cells, 'both' - inside and outside the cells print.digits.legend=print.digits.legend, #the number of digits that should appear in the legend print.digits.cells=print.digits.cells, #the number of digits that should appear in the cells (of the matrix and/or legend) print.cells.mf=print.cells.mf, #if not null, the above argument is igonred, the cell values are printed as the cell are multiplied by this factor and rounded outer.title=outer.title, #should the title be printed on the 'inner' or 'outer' plot, default is 'inner' if legend is ploted and 'outer' otherwise title.line= title.line, #the line (from the top) where the title should be printed mar= mar, #A numerical vector of the form 'c(bottom, left, top, right)' which gives the lines of margin to be specified on the four sides of the plot. The default is 'c(5, 4, 4, 2) + 0.1'. cex.val=cex.val, #size of the values printed val.y.coor.cor = val.y.coor.cor, #correction for centering the values in the sqares in y direction val.x.coor.cor = val.x.coor.cor, #correction for centering the values in the sqares in x direction cex.legend=cex.legend, #size of the text in the legend, legend.title=legend.title, #the title of the legend cex.axes=cex.axes, #size of the characters in axes, 'default' makes the cex so small that all categories can be printed print.axes.val=print.axes.val, #should the axes values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL' print.x.axis.val=print.x.axis.val, #should the x axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL' print.y.axis.val=print.y.axis.val, #should the y axis values be printed, 'default' prints each axis if 'rownames' or 'colnames' is not 'NULL' x.axis.val.pos = x.axis.val.pos, #y coordiante of the x axis values y.axis.val.pos = y.axis.val.pos, #x coordiante of the y axis values cex.main=cex.main, cex.lab=cex.lab, yaxis.line=yaxis.line, #the position of the y axis (the argument 'line') xaxis.line=xaxis.line, #the position of the x axis (the argument 'line') legend.left=legend.left,#how much left should the legend be from the matrix legend.up=legend.up, #how much left should the legend be from the matrix legend.size=legend.size, #relative legend size legend.text.hor.pos=legend.text.hor.pos, #horizontal position of the legend text (bottom) - 0 = bottom, 0.5 = middle,... par.line.width = par.line.width , #the width of the line that seperates the partitions par.line.col = par.line.col, #the color of the line that seperates the partitions IM.dens= IM.dens, IM= IM, #Image used for ploting (shaded lines) wIM=wIM, #which IM (if more) should be used for ploting (defualt = wnet) - used if IM is an array use.IM=use.IM, #should IM be used for ploting? dens.leg=dens.leg, blackdens=blackdens, plotLines = plotLines,... ) return(invisible(NULL)) } } dm<-dim(M) if(!inherits(M, c("matrix","mat"))){ pack<-attr(class(M),"package") if(!(is.null(pack))&&pack=="Matrix"){ if(requireNamespace("Matrix")){ M<-as.matrix(M) } else stop("The supplied object needs Matrix packege, but the package is not available (install it!!!).") } else { warning("Attempting to convert object of class ",class(M)," to class 'matrix'. Keep fingers crossed.") M<-as.matrix(M) } } if(replaceNAdiagWith0 & all(is.na(diag(M)))) diag(M)<-0 if(is.null(main)){ objName<-deparse(substitute(M)) if(objName[1]=="x"){ objName<-deparse(substitute(x)) } if(length(objName)>1) objName="" main <- paste("Matrix",objName) if(nchar(main)>50) main<-substr(main,1,50) } #if(length(main)>26) if(is.logical(print.axes.val)){ print.x.axis.val<-print.y.axis.val<-print.axes.val } #defining text on the axes if row or colnames do not exist if(is.null(rownames(M))){ rownames(M)<-1:dm[1] } if(is.null(colnames(M))){ colnames(M)<-1:dm[2] } if(!is.null(clu)){ #is any clustering provided, ordering of the matrix if 'TRUE' if(is.list(clu)){ clu<-lapply(clu,function(x)as.integer(as.factor(x))) tmNclu<-sapply(clu,max) for(iMode in 2:length(tmNclu)){ clu[[iMode ]]<-clu[[iMode ]]+sum(tmNclu[1:(iMode -1)]) } unlistClu<-unlist(clu) if( all(length(unlistClu)==dm)) clu<-unlistClu } if(!is.list(clu)){ tclu<-table(clu) or.c<-or.r<-order(clu) clu<-list(clu,clu) lines.col<-cumsum(tclu)[-length(tclu)]*1/dm[2] lines.row<-1-lines.col }else if(is.list(clu)&&length(clu)==2){ if(!is.null(clu[[1]])){ tclu.r<-table(clu[[1]]) or.r<-order(clu[[1]]) lines.row<- 1-cumsum(tclu.r)[-length(tclu.r)]*1/dm[1] } else{ or.r<-1:dim(M)[1] lines.row<-NULL } if(!is.null(clu[[2]])){ tclu.c<-table(clu[[2]]) or.c<-order(clu[[2]]) lines.col<-cumsum(tclu.c)[-length(tclu.c)]*1/dm[2] } else{ or.c<-1:dim(M)[2] lines.col<-NULL } } else stop("Networks with more that 2 modes (ways) must convert to 1-mode networks before it is sent to this function.") M<-M[or.r,or.c] clu<-lapply(clu,function(x)as.numeric(factor(x))) } if(is.null(IM.dens)){ if(!is.null(IM)&use.IM){ IM.dens<-matrix(-1,ncol=dim(IM)[2],nrow=dim(IM)[1]) for(i in names(dens.leg)){ IM.dens[IM==i]<- dens.leg[i] } } } if(!is.null(IM.dens)){ dens<-matrix(-1,nrow=dm[1], ncol=dm[2]) for(i in unique(clu[[1]])){ for(j in unique(clu[[2]])){ dens[clu[[1]]==i,clu[[2]]==j]<-IM.dens[i,j] } } dens<-dens[or.r,or.c] } if(length(cex.axes)==1) cex.axes<-c(cex.axes,cex.axes) if(cex.axes[1]=="default"){ #defining the size of text on the axes cex.y.axis<-min(15/dm[1],1) }else{ cex.y.axis<-cex.axes[1] } if(cex.axes[2]=="default"){ #defining the size of text on the axes cex.x.axis<-min(15/dm[2],1) }else{ cex.x.axis<-cex.axes[2] } #defining text on the axes yaxe<-rownames(M) xaxe<-colnames(M) ytop <- rep(x=(dm[1]:1)/dm[1],times=dm[2]) #definin the positions of rectangules ybottom<- ytop - 1/dm[1] xright <- rep(x=(1:dm[2])/dm[2],each=dm[1]) xleft <- xright - 1/dm[2] if(all(M %in% c(0,1))){ # browser() mulCol<-mulCol if(is.null(colByRow)&is.null(colByCol)) { colByRow<-colByCol<-colByUnits } else { if(is.null(colByRow)){ colByRow<-rep(0, length(colByCol)) mulCol<-1 } if(is.null(colByCol)){ colByCol<-rep(0, length(colByRow)) } colByUnits<-TRUE } col<-M if(all(col %in% c(0,1))& (!is.null(colByUnits))){ newCol<-outer(colByRow,colByCol*mulCol,FUN=joinColOperator) if(!is.null(clu)) newCol<-newCol[or.r,or.c] if(colTies){ col[M>0]<-col[M>0]+newCol[M>0] }else{ newCol[newCol>0]<-newCol[newCol>0]+1 col[M==0]<-col[M==0]+newCol[M==0] } } } else { aM<-abs(M) if(!is.null(maxValPlot)){ aM[aM>maxValPlot]<-maxValPlot } max.aM<-max(aM) aMnorm<-as.vector(aM)/max.aM if(max.aM!=0){ col<-gray(1-aMnorm) #definin the color of rectangules }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 par(mar=mar, xpd=NA) #ploting plot.default(c(0,1),c(0,1),type="n",axes=FALSE,ann=FALSE,xaxs="i",asp=asp,...) if(is.null(IM.dens)||all(IM.dens==-1)){ rect(xleft=xleft, ybottom=ybottom, xright=xright, ytop=ytop, col=col,cex.lab=cex.lab,border=if(plotLines)"black" else NA) }else{ rect(xleft=xleft, ybottom=ybottom, xright=xright, ytop=ytop, col=col,cex.lab=cex.lab,density=dens,border=if(plotLines)"black" else NA) } if(frameMatrix) rect(xleft=0, ybottom=0, xright=1, ytop=1, cex.lab=cex.lab,border="black") if(!is.null(clu)){ #ploting the lines between clusters if(!is.null(lines.row)) segments(x0=x0ParLine,x1=x1ParLine,y0=lines.row,y1=lines.row,col=par.line.col,lwd=par.line.width) if(!is.null(lines.col)) segments(y0=y0ParLine,y1=y1ParLine,x0=lines.col,x1=lines.col,col=par.line.col,lwd=par.line.width ) } colYlabels <- colXlabels <- 1 if((length(colLabels)==1)&&is.logical(colLabels)){ if(colLabels){ if(is.null(clu)){ warning("clu not used!") } else { colYlabels <- clu[[1]] colXlabels <- clu[[2]] } } } else{ if(!is.list(colLabels))colLabels<-list(colLabels,colLabels) if(length(colLabels[[1]])==dm[1]){ colYlabels<-colLabels[[1]] } else { warning("colLabels for first dimmension of wrong length, no colors will be used!") } if(length(colLabels[[2]])==dm[2]){ colXlabels<-colLabels[[2]] } else { warning("colLabels for second dimmension of wrong length, no colors will be used!") } } if(!is.null(clu)){ if(length(colXlabels)>1) colXlabels<-colXlabels[or.c] if(length(colYlabels)>1) colYlabels<-colYlabels[or.r] } if(print.y.axis.val) text(x=y.axis.val.pos, y = (dm[1]:1)/dm[1]-1/dm[1]/2 +val.y.coor.cor,labels = yaxe,cex=cex.y.axis,adj=1, col=colYlabels) if(print.x.axis.val) text(y=x.axis.val.pos, x = (1:dm[2])/dm[2]-1/dm[2]/2 +val.x.coor.cor, srt=90, labels = xaxe, cex=cex.x.axis,adj=0, col=colXlabels) title(outer=outer.title,ylab=ylab,xlab=xlab,main=main, line=title.line,cex.main=cex.main) if(print.val){ #ploting the values in the cells if selected norm.val<-as.vector(M)/max(abs(M)) aMnorm<-abs(norm.val) col.text<-1-round(aMnorm) if(!print.0) col.text[as.vector(M)==0]<-0 if(length(table(col.text))==2) { col.labels<-c("white","black") } else col.labels<-c("white") col.text<-as.character(factor(col.text,labels=col.labels)) if(!is.null(IM.dens)&&!all(IM.dens==-1)) col.text[col.text=="white"&dens>0&dens=1){ xright.legend<- -legend.left xleft.legend <- xright.legend - 1*legend.size*asp ybottom.legend <- 1+(4:0)*legend.size+ legend.up ytop.legend <- ybottom.legend + 1*legend.size }else{ xright.legend<- -legend.left xleft.legend <- xright.legend - 1*legend.size ybottom.legend <- 1+(4:0)*legend.size*asp+ legend.up ytop.legend <- ybottom.legend + 1*legend.size*asp } col.legend<-gray(4:0/4) rect(xleft=xleft.legend, ybottom=ybottom.legend, xright=xright.legend, ytop=ytop.legend, col=col.legend) if(print.legend.val=="out"|print.legend.val=="both") text(x=xright.legend + 1/20,y= (ytop.legend+ybottom.legend)/2, labels=formatC(0:4/4*max(M), digits = print.digits.legend,format="g"),adj=0,cex=cex.legend) text(x=xleft.legend,y=ytop.legend[1] + legend.size/asp/2+0.02, labels=legend.title,font=2,cex=cex.legend,adj=0) if(print.legend.val=="in"|print.legend.val=="both"){ col.text.legend<-round(4:0/4) if(!print.0) col.text.legend[1]<-0 col.text.legend<-as.character(factor(col.text.legend,labels=c("white","black"))) if(!print.val){ if(is.null(print.cells.mf)){ if(all(trunc(M)==M)& max(M)<10^print.digits.cells){ multi<-1 }else{ multi<-floor(log10(max(M))) multi<-(multi-(print.digits.cells - 1))*(-1) multi<-10^multi } }else multi <- print.cells.mf maxM<-round(max(M)*multi) } else maxM<-max(M.plot) text(x=(xleft.legend+xright.legend)/2,y=(ytop.legend+ybottom.legend)/2, labels=round(0:4/4*maxM),col=col.text.legend,cex=cex.legend) } } par(mar=old.mar) } #' @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.R0000644000176200001440000000134313663463024015643 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.R0000644000176200001440000000263013663463024014565 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.R0000644000176200001440000001345713654621042020567 0ustar liggesusers# to do - here and in C-functions --> put functional blocks before regular !!! cStatus<-list( blockTypes=c("nul", "com", "cfn", "rfn", "reg", "cre", "rre", "avg", "dnc"), #add before average regFuns=c("max","sum","mean"), homFuns=c("ss", "ad"), implementedApproaches=c("hom", "bin","val") # ,maxBlockTypes=as.integer(10) ) # zgornje spremenljivke morajo biti enake kot v C-ju (blockmodeling.c) allInDimEqual<-function(arr,d)all(apply(arr,d,function(x){x<-as.vector(x);all(x==x[1])})) clu2parArr<-function(clu){ if(!is.list(clu))clu<-list(clu,clu) nrc<-sapply(clu,length) clu<-lapply(clu,function(x)as.integer(as.factor(x))) nUnitsInRCclu<-lapply(clu,function(x)as.integer(table(x))) nRCclu<-sapply(nUnitsInRCclu,length) rowParArr<-matrix(as.integer(0),nrow=nrc[1],ncol=nRCclu[1]) for(i in clu[[1]]){ rowParArr[1:nUnitsInRCclu[[1]][i],i]<-as.integer(which(clu[[1]]==i)-1) } colParArr<-matrix(as.integer(0),nrow=nrc[2],ncol=nRCclu[2]) for(i in clu[[2]]){ colParArr[1:nUnitsInRCclu[[2]][i],i]<-as.integer(which(clu[[2]]==i)-1) } return(list(rowParArr=rowParArr,colParArr=colParArr,nUnitsInRCclu=nUnitsInRCclu, nRCclu=nRCclu, nrc=nrc)) } parArr2clu<-function(nUnitsRowClu, nUnitsColClu, rowParArr, colParArr, nColClus=NULL, nRowClus=NULL){ clu<-list(parArrOne2clu(nUnitsClu=nUnitsRowClu, parArr=rowParArr, nClus=nRowClus),parArrOne2clu(nUnitsClu=nUnitsColClu, parArr=colParArr, nClus=nColClus)) } parArrOne2clu<-function(nUnitsClu, parArr,nClus=NULL){ if(is.null(nClus)){ nClus<-dim(parArr)[2] } else { if(nClus!=dim(parArr)[2]) warning("Number of clusters and dimmension of the partition array do not match") } n<-sum(nUnitsClu) clu<-rep(NA,n) for(i in 1:nClus){ clu[parArr[(1:nUnitsClu[i]),i]+1]<-i } return(clu) } IMaddNames<-function(IM){ array(factor(IM+1,labels=cStatus$blockTypes,levels=1:length(cStatus$blockTypes)),dim=dim(IM)) } formatPreSpecM<-function(preSpecMorg,dB,blocks){ if(is.null(preSpecMorg)){ preSpecM <- array(as.double(NA),dim=dB) } else if (is.vector(preSpecMorg)){ if(length(preSpecMorg)==1){ preSpecM <- array(as.double(preSpecMorg),dim=dB) } else if(length(preSpecMorg)==dB[2]){ preSpecM <- array(as.double(NA),dim=dB) for(i in 1:dB[2]){ preSpecM[,i,,]<-as.double(preSpecMorg[i]) } } else if((dB[2]==1) & (length(preSpecMorg)==dB[1]) & allInDimEqual(blocks,1)){ preSpecM <- array(as.double(NA),dim=dB) for(i in 1:dB[1]){ preSpecM[i,,,]<-as.double(preSpecMorg[i]) } } else stop("'",deparse(substitute(preSpecMorg)),"' is a vector with unexpected length") } else if(is.array(preSpecMorg)){ preSpecM <- array(as.double(preSpecMorg),dim=dim(preSpecMorg)) if(any(dim(preSpecM)!=dB)){ stop("dimensions of '",deparse(substitute(preSpecMorg)),"' and 'blocks' do not match") } } return(preSpecM) } computeCombWeights<-function(combWeights, dB, blocks, relWeights, posWeights, blockTypeWeights){ if(!is.null(combWeights)){ if(all(dim(combWeights)==dB)){ combWeights<-array(as.double(combWeights),dim=dim(combWeights)) return(combWeights) } warning("Dimmensions of the combWeights does not match the dimmensions of blocks!\nIt will not be used!\nIf possible it will be computed using other weights!") } combWeights<-array(as.double(1),dim=dB) relWeights<-as.double(relWeights) if(length(relWeights)!=dB[2]){ if(length(relWeights)==1) relWeights<-rep(relWeights,dB[2]) else stop("To relWeights should have length equal to the number of relations!") } for(i in 1:dB[2]){ combWeights[,i,,]<-combWeights[,i,,]*relWeights[i] } if(all(dim(posWeights)!=dB[3:4])){ if(length(posWeights)==1) posWeights<-array(posWeights,dim=dB[3:4]) else stop("To posWeights should have the same dimensions as block image!") } posWeights<-array(as.double(posWeights), dim=dim(posWeights)) for(i in 1:dB[3]){ for(j in 1:dB[4]){ combWeights[,,i,j]<-combWeights[,,i,j]*posWeights[i,j] } } if(!(is.numeric(blockTypeWeights)&all(names(blockTypeWeights)%in%cStatus$blockTypes))) stop("blockTypeWeights must be a numeric named vector with names from: ", paste(cStatus$blockTypes, collapse=", ")) for(i in names(blockTypeWeights)){ tWhich <- blocks==i tWhich[is.na(tWhich)]<-FALSE combWeights[tWhich]<-blockTypeWeights[i]* combWeights[tWhich] } return(combWeights) } formatUsePreSpecM<-function(usePreSpecMorg,preSpecM,dB,blocks){ if(is.null(usePreSpecMorg)){ usePreSpecM<- !is.na(preSpecM) }else if(is.vector(usePreSpecMorg)){ if(length(usePreSpecMorg)==dB[2]){ usePreSpecM <- array(as.integer(NA),dim=dB) for(i in 1:dB[2]){ usePreSpecM[,i,,]<-as.integer(usePreSpecMorg[i]) } } else if((dB[2]==1) & (length(usePreSpecMorg)==dB[1]) & allInDimEqual(blocks,1)){ usePreSpecM <- array(as.integer(NA),dim=dB) for(i in 1:dB[1]){ usePreSpecM[i,,,]<-as.integer(usePreSpecMorg[i]) } } else stop("'",deparse(substitute(usePreSpecM)),"' is a vector with unexpected length") } else if(is.array(usePreSpecMorg)){ if(any(dim(usePreSpecMorg)!=dB)){ stop("dimensions of '",deparse(substitute(usePreSpecM)),"' and 'blocks' do not match") } usePreSpecM <- array(as.integer(usePreSpecMorg),dim=dim(usePreSpecMorg)) } return(usePreSpecM) } blockmodeling/R/parOKgroups.R0000644000176200001440000000031013654621042015660 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.R0000644000176200001440000000065014026573212014635 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.R0000644000176200001440000000310213663721416016021 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.R0000644000176200001440000001013013677022357017620 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 #' @useDynLib blockmodeling, .registration = TRUE NULLblockmodeling/R/plot.mat.nm.R0000644000176200001440000000256314077503476015601 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.R0000644000176200001440000000635613663463024016000 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(class(n)=="mat") n<-unclass(n) n <- as(n,"dgTMatrix") useMatrix<-TRUE }else{ pack<-attr(class(n),"package") if(!(is.null(pack))&&pack=="Matrix") stop("The supplied object needs Matrix packege, but the package is not available.") useMatrix<-FALSE } if(dim(n)[1]!=dim(n)[2]){ twomode<-2 }else if(twomode=="default")twomode<-1 if(is.null(symetric))if(twomode==1){ if(useMatrix){symetric<-all(n==Matrix::t(n)) }else symetric<-all(n==t(n)) } else symetric<-FALSE pack<-attr("package",class(n)) if ((dim(n)[1] == dim(n)[2]) & (twomode!=2)){ cat(paste("*Vertices",dim(n)[1]),eol, file = filename); cat(paste(seq(1,length=dim(n)[1]),' "',rowNames,'"',eol,sep=""), file = filename,append=TRUE); if(useMatrix){ nDf<-as.data.frame(attributes(n)[c("i","j","x")]) nDf[,c("i","j")]<-nDf[,c("i","j")]+1 if(symetric){ cat("*Edges",eol, file = filename,append=TRUE) nDf<-nDf[nDf$i<=nDf$j,] write.table(nDf[,],eol=eol,file=filename,row.names = FALSE,col.names = FALSE,append=TRUE) } else { cat("*Arcs",eol, file = filename,append=TRUE) write.table(nDf[,],eol=eol,file=filename,row.names = FALSE,col.names = FALSE,append=TRUE) } }else{ if(symetric){ cat("*Edges",eol, file = filename,append=TRUE) for (i in 1:dim(n)[1]) { for (j in 1:(i)) { if (n[i,j]!=0) {cat(paste(i,j,n[i,j],eol),file = filename,append=TRUE)} } } }else{ cat("*Arcs",eol, file = filename,append=TRUE); for (i in 1:dim(n)[1]) { for (j in 1:dim(n)[2]) { if (n[i,j]!=0) {cat(paste(i,j,n[i,j],eol),file = filename,append=TRUE)} } } } } }else { cat(paste("*Vertices",sum(dim(n)),dim(n)[1]),eol, file = filename); cat(paste(1:dim(n)[1],' "',rowNames,'"',eol,sep=""), file = filename,append=TRUE); cat(paste(seq(dim(n)[1]+1,length=dim(n)[2]),' "',colNames,'"',eol,sep=""), file = filename,append=TRUE); cat("*Edges",eol, file = filename,append=TRUE); if(useMatrix){ nDf<-as.data.frame(attributes(n)[c("i","j","x")]) nDf[,c("i","j")]<-nDf[,c("i","j")]+1 nDf$j<-nDf$j+dim(n)[1] write.table(nDf[,],eol=eol,file=filename,row.names = FALSE,col.names = FALSE,append=TRUE) }else{ for (i in 1:dim(n)[1]) { for (j in 1:dim(n)[2]) { if (n[i,j]!=0) {cat(paste(i,j+dim(n)[1],n[i,j],eol),file = filename,append=TRUE)} } } } } } , comment = "Save matrix to file that can be read by Pajek (as *Arcs)") blockmodeling/R/fun.by.blocks.default.R0000644000176200001440000000342614077547045017531 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[1]) if(is.list(clu)){ nmode<-length(clu) if(nmode>2){ clu<-unlist(clu) clu<-list(clu,clu) } } else { clu<-list(clu,clu) nmode<-1 } clu<-lapply(clu,factor) if(ignore.diag =="default"){ if(length(dM)==3){ ignore.diag <-all(apply(M,1,function(x)identical(ss(diag(x)),0)))&(nmode==1) } else ignore.diag <-identical(ss(diag(M)),0)&(nmode==1) } if(sortNames) { k <- lapply(clu,function(x)sort(unique(x))) }else { k <- lapply(clu,function(x)unique(x)) } IM.V <- array(NA, dim=c(nn,length(k[[1]]),length(k[[2]]))) dimnames(IM.V)<-c(list(1:nn),k) for(iNet in 1:nn){ if(length(dM)==3) iM <- M[iNet,,] else iM<-M for (i in k[[1]]) { for (j in k[[2]]) { B<-iM[clu[[1]] == i, clu[[2]] == j, drop = FALSE] if (nmode==1 && i == j && ignore.diag) diag(B) <- NA #removed "dim(B)[1] > 1 &&" from condition above - produces NA's in IM in the diagonal blocks in case of dimension 1x1 lpar<-list(x = B,...) FUNchar<-FUN if(!is.character(FUNchar)) FUNchar<-deparse(substitute(FUN)) if(FUNchar %in% c("mean","sum","min","max")){ if(!("na.rm"%in%names(lpar))) lpar<-c(lpar, list(na.rm=TRUE)) } IM.V[iNet,i, j] <- do.call(FUN, lpar)#, na.rm = TRUE } } } if(nn==1) return(IM.V[1,,]) else return(IM.V) } blockmodeling/R/loadnetwork2.R0000644000176200001440000001116113663463024016031 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.R0000644000176200001440000000123713716716547016734 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.R0000644000176200001440000000125713717144240017643 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.r0000644000176200001440000000263113663463024016260 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.R0000644000176200001440000000555313654621042017177 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.R0000644000176200001440000000127113667655602014341 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.R0000644000176200001440000000537513663463024015362 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.R0000644000176200001440000000226613663463024015136 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.R0000644000176200001440000000066013663463024015015 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.R0000644000176200001440000000215014077503476015714 0ustar liggesusers#' @encoding UTF-8 #' @title Niceprinting 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){ 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.R0000644000176200001440000000553214077547045015652 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 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 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 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.R0000644000176200001440000000123513717144240016676 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.R0000644000176200001440000001612713663721416014602 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.R0000644000176200001440000000034013663463024015154 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.R0000644000176200001440000000005313654621042015052 0ustar liggesusers"meanpos" <- function(v){mean(v[v>0])} blockmodeling/R/formatA.R0000644000176200001440000000157713663721416015023 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.R0000644000176200001440000000106213716720502017333 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.R0000644000176200001440000000241613663721416016444 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.R0000644000176200001440000000212314077547045020422 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.R0000644000176200001440000000440214076020070015202 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} (default), dimensions that have only one level are dropped (\code{drop} function is applied to the final result). #' #' #' @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}} #' #' #' @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.R0000644000176200001440000000065213663463024015602 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.R0000644000176200001440000000443113663463024015055 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.R0000644000176200001440000000743213663463024016041 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.R0000644000176200001440000000144614026573212014043 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.R0000644000176200001440000005213214112157172016124 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} be used (otherwise \code{mforeach} is used). Defaults to true as it needs less dependencies. It might be removed in future releses and only allow the use of parLapplyLB. #' @param cl The cluster to use (if formed beforehand). Defaults to \code{NULL}. #' @param stopcl Should the cluster be stoped after the function finishes. Defaults to \code{is.null(cl)}. #' @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 = TRUE, # Should parLapplyLB be used (otherwise foreach is used) cl = NULL, #the cluster to use (if formed beforehand) stopcl = is.null(cl), # should the cluster be stoped ... #paramters to optParC ){ dots<-list(...) #this might not be need - can be removed and all latter occurencies given sufficent testing. Left for now as there is not enought time. if(is.null(switch.names)){ 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) on.exit({ res1 <- res[which(err==min(err, na.rm = TRUE))] best<-NULL best.clu<-NULL for(i in 1:length(res1)){ for(j in 1:length(res1[[i]]$best)){ if( ifelse(is.null(best.clu), TRUE, if(nmode==1) ifelse(switch.names, !any(sapply(best.clu,rand2,clu2=res1[[i]]$clu)==1), !any(sapply(best.clu,function(x)all(x==res1[[i]]$clu))) ) else ifelse(switch.names, !any(sapply(best.clu,function(x,clu2)rand2(unlist(x),clu2),clu2=unlist(res1[[i]]$clu))==1), !any(sapply(best.clu,function(x)all(unlist(x)==unlist(res1[[i]]$clu)))) ) ) ){ best<-c(best,res1[i]) best.clu<-c(best.clu,list(res1[[i]]$clu)) } if(length(best)>=max.iden) { warning("Only the first ",max.iden," solutions out of ",length(na.omit(err))," solutions with minimal error will be saved.\n") break } } } names(best)<-paste("best",1:length(best),sep="") if(any(na.omit(err)==Inf) || ss(na.omit(err))!=0 || length(na.omit(err))==1){ cat("\n\nOptimization of all partitions completed\n") cat(length(best),"solution(s) with minimal error =", min(err,na.rm=TRUE), "found.","\n") }else { cat("\n\nOptimization of all partitions completed\n") cat("All",length(na.omit(err)),"solutions have err",err[1],"\n") } call<-list(call=match.call()) best<-list(best=best) checked.par<-list(checked.par=skip.par) if(return.all) res<-list(res=res) else res<-NULL if(return.err) err<-list(err=err) else err<-NULL if(!exists("initial.param")){ initial.param<-NULL } else initial.param=list(initial.param) res<-c(list(M=M),res,best,err,list(nIter=nIter),checked.par,call,initial.param=initial.param, list(Random.seed=.Random.seed)) class(res)<-"optMorePar" return(res) }) 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(class(tres)=="try-error"){ tres<-list("try-error"=tres, err=Inf, nIter=Inf, startPart=temppar) } if(deleteMs){ tres$M<-NULL tres$resC$M<-NULL } # err[i]<-res[[i]]$err # nIter[i]<-res[[i]]$resC$nIter return(list(tres)) } 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)) cl<-makeCluster(nCores) clusterSetRNGStream(cl) nC<-nCores #clusterExport(cl, varlist = c("kmBlock","kmBlockORP")) #clusterExport(cl, varlist = "kmBlock") clusterExport(cl, varlist = "pkgName", envir=environment()) clusterEvalQ(cl, expr={require(pkgName,character.only = TRUE)}) 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,...) 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(!foreach::getDoParRegistered()){ doParallel::registerDoParallel(nCores) } nC<-foreach::getDoParWorkers() 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) } } } 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.R0000644000176200001440000000735113663463024016040 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.R0000644000176200001440000000005113654621042014734 0ustar liggesusers"sumpos" <- function(v){sum(v[v>0])} blockmodeling/R/printRes.R0000644000176200001440000000275414077503476015242 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") }blockmodeling/R/unlistCluInt.R0000644000176200001440000000260414075775361016065 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}} #' @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.R0000644000176200001440000000754613733073300014205 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(class(res)%in%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(class(res)%in%c("optMorePar","opt.more.par")){ EM<-res$best[[which]]$EM } else EM<-res$EM if(drop)EM<-drop(EM) return(EM) } blockmodeling/R/savematrix.R0000644000176200001440000000404713663463024015606 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.R0000644000176200001440000000736114077547045015212 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(any(class(x)%in%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.R0000644000176200001440000000140113663721416014655 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.R0000644000176200001440000000052713667213444016132 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.R0000644000176200001440000000102314026573212015326 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.R0000644000176200001440000000032413663463024014530 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.R0000644000176200001440000001427013663721416014146 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.R0000644000176200001440000000137114026573212014652 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.R0000644000176200001440000000665713663463024016161 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.R0000644000176200001440000000124113717556107015761 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.R0000644000176200001440000000575314076020070013724 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. #' @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 allowed in randomized networks or not, default \code{TRUE}. #' @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 funcion 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 ranomized in such a way that the values on the links are randomly relocated. #' @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) #' # Install package blockmodeling and then run the following lines. #' 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 Ales Ziberna #' @references Cugmas, M., Žiberna, A., & Ferligoj, A. (2019). Mechanisms Generating Asymmetric Core-Cohesive Blockmodels. Metodološki Zvezki, 16(1), 17-41. #' @export RF <- function(res, m = 10, loops = TRUE){ errs <- vector(length = m) for (i in 1:m){ randomized <- matrix(sample(res$initial.param$M), nrow = nrow(res$initial.param$M)) if (loops == FALSE){ diagonalni <- diag(randomized)[diag(randomized) != 0] diag(randomized) <- -1 randomized[sample(which(randomized == 0), replace = FALSE, size = length(diagonalni))] <- sample(diagonalni) diag(randomized) <- 0 } 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.R0000644000176200001440000000740613663463024014552 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{gplot} from package \code{sna}:\cr\cr #' \bold{\code{mode}}: the vertex placement algorithm; this must correspond to a \code{gplot.layout} function from package \code{sna}. #' #' @return Plots a graph. #' #' @author \enc{Aleš Žiberna}{Ales Ziberna} #' @seealso \code{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.R0000644000176200001440000000246413663463024014661 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/MD50000644000176200001440000001404414114263762013404 0ustar liggesusers25de82e7420a58597951fef417af4309 *CHANGES 92751d4721339ef51044e26bf0ac538c *DESCRIPTION 2f3e6e08b30191eaf4a791f137cc01cf *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 6d7583b9bf5cf3d69eba6dbfa2e154f4 *R/RF.R 1b58b7e171407473ec4e7c0cbdb02e9e *R/blockmodeling-package.R f58d2084fa5b53e126295d6a1d7086eb *R/canClu.R 361711e290f2d01c6f77e0847af981fd *R/clu.R d662210bc6e8b1b11346b2c6682bf96c *R/critFunC.R a664559885166d1e489b50518c8e2b24 *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 cc39e85e71f0e0335728138ac9d4d66c *R/fun.by.blocks.default.R 3a4e3dccfad457b69e54e906f6f38eb0 *R/fun.by.blocks.opt.more.par.R 47334ffcd97cabbc44dad164c5252fce *R/funByBlocks.R 8008d09a47dafb042943e3debe886f33 *R/genMatrixMult.r a258b5c12fce28be91c57ac3e43908dc *R/genRandomPar.R 6471680113a196880a13826db1279a70 *R/genRandomParGroups.R 5051fd6a852aaf6f745f617e1b5234cc *R/gplot.R 6feaa9021e600269173cb9da34504be9 *R/ircNorm.R 3c93e1ab79dd3d199cd028ad0fce4030 *R/loadmatrix.R 7b2251914ec27cb31a779e6f6f716b66 *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 ea7a900d648473fe8e410f88704e8235 *R/optRandomParC.R 73b6d25f8829a5b4629f168ba47617ff *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 12ba6a20b040b60c80deb146d10a0a7a *R/plotMat.R ccdde39f91ec0bf84c157afa30d65cd7 *R/printBlocks.R ade41dab5db979f98370d9b602d7c2fe *R/printRes.R 6d815ac48f68f8251ee9e1908ae4ab4a *R/rand-multiple.R cb9dbafff6f238b950a92c0b240c1025 *R/recode.R b4e507db9b1e179e4c49f7286ddc2933 *R/relInv.R c1471e7102889f0cf3b1879c3b52f73f *R/reorderImage.R 5edcfcd8c4db41f128a886081ca3ecb7 *R/savematrix.R 739b706890a2c976698bb8be932f67f1 *R/savenetwork.R 3b3ca7b333d508bda8d08e84562780a9 *R/savevector.R 36e44773de2892bbb8a2d8892eb1ec57 *R/sedist.R be37437ffe179966ee23a98c7d5071e5 *R/splitClu.R d3d9923fa9e7d400c0eef0df8d6cb07f *R/ss.R 83f0894ed4e7b2baebc45ce5e4d3ea1a *R/sumpos.R 3c0470a39c9cfe729b91535a7bc25df4 *R/two2one.R 981e137ab09b21d43f34f871a401dd56 *R/unlistCluInt.R cf56197339441d8de415e553dd25c348 *R/useneg.R 4c2cfa53f258d295e139a924e2208646 *R/usepos.R 81197f44e8bde5b5977fd8fa5b3c1920 *data/baker.rda f49dc1f244e3a2e2996a1f223761f2e9 *data/notesBorrowing.RData 497089ea38d28cfa4d0892b449db045e *inst/CITATION 478160e7b1a4049564ac88e56896f9f0 *man/Pajek.Rd fcbcb4d2b1433b21f7da05b8f0354c31 *man/REGE.Rd f04b6792d5f6b04639c91a252b7eb01d *man/RF.Rd aa03ae102504a12c8ecf07f8dd845079 *man/baker.Rd 50ed2a91016d89338e7532685de86995 *man/blockmodeling.Rd b973434f34a18954f83a959f422149b5 *man/canClu.Rd 4e553af122608bd708a490b482a8b52b *man/clu.Rd 3fb7be28f19db9a4008e97f4c2d71ea8 *man/critFunC.Rd db29c28cb315e5804e5baf94a5a572ce *man/expandMat.Rd 29846790266e614ca698f794bcbaa07c *man/find.m.Rd 7175c1a4a9b0e7c3619f78b8343a0724 *man/formatA.Rd c8cadfd06fe48531c854e433566fb39b *man/funByBlocks.Rd cf8997b03bee9d5c6999f04a5a97d6bd *man/genMatrixMult.Rd 2f9d6a58ed04a979d77b66f76e1ebe1b *man/genRandomPar.Rd 45c1a657662b31b9f23a0f4d631640b7 *man/gplot1.Rd 9854d5c0f60b1976bb18b0522db1c5e6 *man/ircNorm.Rd 6ed92f4642658097455deb97f404ce9f *man/nanRep.Rd dabd263af46b75169c380f3ddf015818 *man/nkpartitions.Rd 632908f874a3f94c368009070a47a047 *man/notesBorrowing.Rd 66ee265965e30e46278843d43eb18e2c *man/optRandomParC.Rd ab932bd087388397df3201ad8bc29015 *man/orderClu.Rd 82aa595b0d4e7a354726fd971251874d *man/plotMat.Rd 42e89a217c14224251d5eebc5d206bdb *man/printBlocks.Rd 0b6a43af4e0dd0f83f58516e317fd2f9 *man/rand.Rd 4b37a8eb7c6e947638900b72956c787e *man/recode.Rd 60e9cda73345ca85717d6760abe30f4d *man/relInv.Rd cf47e39e94e61535193d3600f3f202f4 *man/reorderImage.Rd a932b77d048140b14035850443d0ff94 *man/sedist.Rd 4ecb180a3b64a9d015f098a387b448ca *man/splitClu.Rd 9c126c89dce1192749102f48e170863d *man/ss.Rd 86e7b49bee3781c4267c7e1c943ecd24 *man/two2one.Rd 1f3aca14837c58a43b96898bef6acd56 *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 858ac8c45182e50383152b0747623910 *src/blockmodelingC.c b1040e84d15384979654d36a9f245560 *src/init.c blockmodeling/inst/0000755000176200001440000000000014112161612014033 5ustar liggesusersblockmodeling/inst/CITATION0000644000176200001440000000422313654621042015201 0ustar liggesuserscitHeader("To cite package '",meta$Package,"' in publications please use package citation and (at least) one of the articles:", sep="") # Grab the version and date from the DESCRIPTION file year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date) vers <- paste("R package version", meta$Version) aut<-eval(parse(text=meta$"Authors@R")) autText<-format(aut, include = c("family", "given"), braces = list(family = c("", ","))) citEntry(entry = "Article", title = "Generalized blockmodeling of valued networks", volume = "29", shorttitle = "Generalized blockmodeling of valued networks", # doi = "10.1016/j.socnet.2006.04.002", journal = "Social Networks", author = as.person("Aleš Žiberna"), year = "2007", number = "1", pages = "105--126", textVersion= "Žiberna, Aleš (2007). Generalized blockmodeling of valued networks. Social Networks 29(1), 105-126." ) citEntry(entry = "Article", title = "Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence", volume = "32", shorttitle = "Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence", doi = "10.1080/00222500701790207", journal = "Journal of Mathematical Sociology", author = as.person("Aleš Žiberna"), year = "2008", number = "1", pages = "57--84", textVersion = "Žiberna, Aleš (2008). Direct and indirect approaches to blockmodeling of valued networks in terms of regular equivalence. Journal of Mathematical Sociology 32(1), 57–84." ) citEntry(entry = "Article", title = "Blockmodeling of Multilevel Networks", volume = "39", shorttitle = "Blockmodeling of Multilevel Networks", doi = "10.1016/j.socnet.2014.04.002", journal = "Social Networks", author = as.person("Aleš Žiberna"), year = "2014", pages ="46-61", textVersion = "Žiberna, Aleš (2014). Blockmodeling of multilevel networks. Social Networks 39, 46–61. https://doi.org/10.1016/j.socnet.2014.04.002." ) citEntry(entry="Manual", title = meta$Title, author= aut, year =year, note =vers, textVersion= paste(autText," (", year, "). ",meta$Title,", ", vers, ".", sep="") ) blockmodeling/CHANGES0000644000176200001440000001101014112157172014050 0ustar liggesusersName: blockmodeling Title: Generalized and Classical Blockmodeling of Valued Networks 2021 Date: 2021-08-27 A "NOTE" in cran checked fixed - nolonger 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. 2021 Version: 1.0.2 Date: 2021-03-24 Utility functions added. February 1, 2020 plot.array removed - only goes by name plotArray. Minor bug fixes. 2020 August 1, 2020 Version 1.0.1 Various bugs fixed. 2020 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).