Commit bb65934a authored by Michael R. Crusoe's avatar Michael R. Crusoe

New upstream version 0.3.4

parent 309caad0
......@@ -2,10 +2,35 @@ Name: blockmodeling
Title: Generalized and Classical Blockmodeling of Valued Networks
2018
December 24, 2018
Added two arguments into optRandomParC (approaches and blocks). Also the description of these arguments was added into optRandomParC.Rd file
November 29, 2018
A bug fixed in kmBlockORP that produced new cluster to be generated each time kmBlockORP was called in multicore mode.
November 9, 2018
Version 0.3.3
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
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.
......@@ -13,12 +38,10 @@ April 25, 2018
Version 0.3.1
A bug fix which prevented the use of functions gplot1 and gplot2.
2018
April 10, 2018
Version 0.3.0
Final tweaks before submission to CRAN.
March 28, 2018
Correcting some FORTRAN warnings.
......@@ -36,17 +59,20 @@ Merged optParMultiC and optParC in to optParC.
Added formating to returned clu from these functions.
June 30, 2017
Seveal bug fixes
Seveal bug fixes.
2014
May 14, 2014
Version: 0.2.2
A bug in sedist fixed
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
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.
......@@ -55,5 +81,5 @@ 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)
\ No newline at end of file
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).
\ No newline at end of file
Package: blockmodeling
Type: Package
Title: Generalized and Classical Blockmodeling of Valued Networks
Version: 0.3.1
Date: 2018-05-29
Version: 0.3.4
Date: 2018-12-24
Imports: stats, methods, Matrix, doParallel, doRNG, parallel, foreach
Suggests: sna
Author: Aleš Žiberna [aut, cre]
......@@ -19,8 +19,8 @@ Encoding: UTF-8
RoxygenNote: 6.0.1
Repository: CRAN
Repository/R-Forge/Project: blockmodeling
Repository/R-Forge/Revision: 133
Repository/R-Forge/DateTimeStamp: 2018-06-04 20:50:17
Date/Publication: 2018-06-04 22:01:08 UTC
Repository/R-Forge/Revision: 217
Repository/R-Forge/DateTimeStamp: 2019-01-07 17:33:04
Date/Publication: 2019-01-08 17:10:09 UTC
NeedsCompilation: yes
Packaged: 2018-06-04 21:15:09 UTC; rforge
Packaged: 2019-01-07 17:52:03 UTC; rforge
300a88d175cd59bbc1686cde8b9570f2 *CHANGES
646a7ff522292db2d87e5ae7c8beedb5 *DESCRIPTION
7c1510eeeec7958c4d1bfb30746c80c7 *NAMESPACE
c9f9b4ecc4a6089725a3a2a5f0f07bcf *R/Cinterfaces.R
d1526aab143db19e5de68b444f674a55 *R/IM.R
ce3484d89fc4dabf171065d8bf3b4ecb *CHANGES
61826f255267332657e26856f2fd51b4 *DESCRIPTION
26849ac0dea36b768593f6e529606805 *NAMESPACE
b6395ed30d90efb9ab2ce2dcc56b9172 *R/Cinterfaces.R
e61012cd30a8017bc95d26a0712e3849 *R/IM.R
2f51422a4e8c43a3461d230c20c5ceb7 *R/REGE.FC.R
80575603ee7dc48ee8f98c313de64389 *R/REGE.FC.ow.R
c01d3f4f538983dcd67acba0b49a757c *R/REGE.R
......@@ -18,21 +18,21 @@ a977bb36598f9afc57c031d0dc71ea35 *R/find.m.R
42b0edaf68e3de9a5415903bc5b5a965 *R/find.m2.R
0d402201cbc4fee68d9d983360aafe3b *R/formatA.R
3381111228d5eda92f751d79fc81a829 *R/fun.by.blocks.R
78c179aa34d04ef47a5d4b316d2bfb30 *R/fun.by.blocks.default.R
d30848515c8e7bf417ba6fc7a1a8fe9f *R/fun.by.blocks.default.R
d32292104d5f90c9e972ce2f221bb8b9 *R/fun.by.blocks.opt.more.par.R
f0e7145262ce7fcbb2ceef97d5b97348 *R/genMatrixMult.r
bb0f305401afbcfb6de916e83f912a2a *R/genRandomPar.R
3edfa00c218f2ca76c1b356db10045b6 *R/genRandomPar.R
6471680113a196880a13826db1279a70 *R/genRandomParGroups.R
24dc303b947ca5834fcb44da664b2c50 *R/gplot.R
919fc6d9be1797e173886e2d843da4ff *R/gplot.R
c6cde87c0909f5e0b6390218c83f0862 *R/ircNorm.R
e2ed7bc03c847e2afb10b534e90ec2c2 *R/loadmatrix.R
67459f46ef34796bcd6d007dc04f1ca5 *R/loadnetwork.R
1483a733202bee93b0a757de60193891 *R/loadnetwork2.R
5ce9ba1ebe2b32157585da9a4fccde00 *R/loadnetwork2.R
a2f48135c230e912ccfc288cac8c8b53 *R/loadnetwork3.R
e7c807776e87e0897aa56426a7f0f928 *R/loadnetwork4.R
41771b806db083b3d621bfb9ae3c9b73 *R/loadpajek.R
04cd626b8dda4e7e0410be30b6b7474a *R/loadpajek.R
55de856028d90f10a2b4f7a218ad08a4 *R/loadvector.R
8f0c288fdc49652415c26b82a9661c22 *R/loadvector2.R
56090fcae62ac3797e134255ee0a8853 *R/loadvector2.R
ef2edf6e5ff44270119306a108458aac *R/mean.max.col.R
c5c9b0bb964a09c8ca251539ce0b65bc *R/mean.max.row.R
0949efc03bfecf760f309b6cd674e915 *R/meanpos.R
......@@ -43,9 +43,9 @@ e7942ed973f79375fe4ef4cab477a948 *R/one2two.R
85b3127c3cea0e54ff37382b36e04226 *R/parOKgroups.R
1c0500ce587f38efb1b6c43d10f68a0f *R/plot.check.these.par.R
d36226b8c596a378c21b59dea8a4a50e *R/plot.crit.fun.R
3fa53667191edde202c455fa625fdac8 *R/plot.mat.R
915bad61c68b624b46121513e0758b42 *R/plot.mat.R
471bb2536526a127ed0b24450170fb90 *R/plot.mat.nm.R
26574da588edffa972704643bed40385 *R/plot.opt.more.par.R
df66c0e2c69e65d060a954b513acb928 *R/plot.opt.more.par.R
a5defacfcf43caecb72e8abc0efa44a4 *R/plot.opt.more.par.mode.R
328a1bcb858918e43cd9fbc850f5ee52 *R/plot.opt.par.R
35d41e265eb1fd901971a930e01348e8 *R/plot.opt.par.mode.R
......@@ -62,28 +62,28 @@ ad59aec2182068c236097be840bccc6e *R/ss.R
57d9f97d53a521b00cb96f961f8c40d6 *R/two2one.R
cf56197339441d8de415e553dd25c348 *R/useneg.R
4c2cfa53f258d295e139a924e2208646 *R/usepos.R
53beefd43ff6494ed982cb73118b0e1c *inst/CITATION
db6def62d499ef2b4ef19fa65c74b767 *man/Pajek.Rd
dfc7d2753573f1fa22b6125593302edb *man/REGE.Rd
d790be0f4dde6d1fd2876d89ee8a5253 *man/blockmodeling-package.Rd
d1dcb269126dbb056b1838af67dbe98b *man/clu.Rd
c07a3b1c9e5e08e6acff4bd13a50300e *man/critFunC.Rd
5bf0b6199208e4437fa0d2f514cf9037 *man/find.m.Rd
fd1381023d11d856ff5a30fe3b222e99 *inst/CITATION
36ee8790ef573cb24b84ff2a90796f00 *man/Pajek.Rd
7b3d4922183bc71b1332e01917dbab28 *man/REGE.Rd
e3d152da5f8e60ecfbd5d9eca5e9f81d *man/blockmodeling-package.Rd
8b883ee27289cd08002254d5e8221974 *man/clu.Rd
a56375fa3b6a48629971cc07a38318f4 *man/critFunC.Rd
61d67444eb932ab528c558eeaa682f5b *man/find.m.Rd
eecd4ea7781f20965d8459bdb49046a8 *man/formatA.Rd
9cf8f78cdcbf67f28bfd94680558782e *man/fun.by.blocks.Rd
505eefeafbbf52b3c5aea0243762a19c *man/fun.by.blocks.Rd
59a128dd4a55c8974e005b46d291db1d *man/genMatrixMult.Rd
c889d3af0b360a35bfa40368736ce9d0 *man/genRandomPar.Rd
e33c35a7bf8627afab5f75efc5c6f379 *man/gplot1.Rd
aff51b0251da59a46ef4f0444271f80b *man/ircNorm.Rd
fa739401088400a6c0288123e9d69fdd *man/nkpartitions.Rd
cc3c96dc77431ef4299454dff20c1d1c *man/optRandomParC.Rd
a7fcd5463de380a9c2d395a57e5d6e66 *man/plot.mat.Rd
81f7d0701254e98214425cbdf405613c *man/rand.Rd
d83bfab538c0753ab8e75c5c67aa5190 *man/recode.Rd
7c162134b4b1b52aafcd580c9467e24b *man/reorderImage.Rd
225573063340fbf4ee6f98eb3f9f7808 *man/sedist.Rd
aa2ca3c62c2a15a3b9ec4205938653b1 *man/genRandomPar.Rd
5bdd3829fd034f862c359f61f187a4ad *man/gplot1.Rd
d1545b825ed319f47eb6cf959c5ab354 *man/ircNorm.Rd
1e92dcb64b5b3ae38c5136fee2ddefc9 *man/nkpartitions.Rd
49ebbe1733996d263dc6744249fdd31a *man/optRandomParC.Rd
b5cd768dee50708e1eed78efefcc18f6 *man/plot.mat.Rd
b2f5ea8e91f3c0052fa5f9101ec51b51 *man/rand.Rd
2b2641f305dd0b2131b1337e537c93f0 *man/recode.Rd
732db23448b114c54b0d1e82c80ad0ed *man/reorderImage.Rd
883a11080c6546c5fc21385749750c53 *man/sedist.Rd
9ae0f360ec198686f2173fc37d5b8f0a *man/ss.Rd
3070b09bd35732b0bce6cd5f967dde3f *man/two2one.Rd
8e00c5a8edd0e40beb39c83d29ce104a *man/two2one.Rd
ee2ce2302b03b54e732b8dcf736a68ee *src/REGD_NE_R.f90
384f54d7e9e77d08e7492637b6bcc4c7 *src/REGD_OW_NE_R.f90
01cef6254bd782214a7f1f976ec9445f *src/REGD_OW_R.f90
......
......@@ -29,7 +29,7 @@ export(find.m, find.m2, find.cut)
export(ss, ad)
export(ircNorm)
export(genMatrixMult)
export(clu, err, IM, reorderImage, partitions)
export(clu, err, IM, EM, reorderImage, partitions)
export(one2two, two2one)
export(recode, formatA)
export(fun.by.blocks)
......
......@@ -181,11 +181,11 @@ critFunC<-function(M, clu, approaches, blocks, isTwoMode = NULL, isSym = NULL,
# }
rowParArr<-matrix(as.integer(0),nrow=dM[1],ncol=nRCclu[1])
for(i in clu[[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 clu[[2]]){
for(i in 1:nRCclu[[2]]){
colParArr[1:nUnitsInRCclu[[2]][i],i]<-as.integer(which(clu[[2]]==i)-1)
}
......@@ -263,6 +263,11 @@ critFunC<-function(M, clu, approaches, blocks, isTwoMode = NULL, isSym = NULL,
}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)
......@@ -305,8 +310,11 @@ critFunC<-function(M, clu, approaches, blocks, isTwoMode = NULL, isSym = NULL,
}
}
}
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)
......@@ -322,7 +330,7 @@ critFunC<-function(M, clu, approaches, blocks, isTwoMode = NULL, isSym = NULL,
}
optParC<-function(M, nMode=NULL,isSym=NULL,diag=1,clu,approaches,blocks, useMulti=FALSE, maxPar=50, IM=NULL,EM=NULL,Earr=NULL, justChange=FALSE, 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){
optParC<-function(M, clu, approaches, blocks, nMode=NULL,isSym=NULL,diag=1, useMulti=FALSE, maxPar=50, IM=NULL,EM=NULL,Earr=NULL, justChange=FALSE, 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
......@@ -481,6 +489,11 @@ optParC<-function(M, nMode=NULL,isSym=NULL,diag=1,clu,approaches,blocks, useMult
}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)
......@@ -583,9 +596,11 @@ optParC<-function(M, nMode=NULL,isSym=NULL,diag=1,clu,approaches,blocks, useMult
### tole je testno
"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
......@@ -611,9 +626,9 @@ n=NULL, #the number of units by "modes". It is used only for generating random p
nCores=1, #number of cores to be used 0 -means all available cores, can also be a cluster object
... #paramters to optParC
){
dots<-list(...)
dots<-list(...) #this might not be need - can be removed and all latter occurencies given sufficent testing. Left for now as there is not enought time.
if(is.null(switch.names)){
switch.names<-is.null(dots$BLOCKS)
switch.names<-is.null(blocks)
}
if(save.initial.param)initial.param<-c(tryCatch(lapply(as.list(sys.frame(sys.nframe())),eval),error=function(...)return("error")),dots=list(...))#saves the inital parameters
......@@ -744,7 +759,7 @@ nCores=1, #number of cores to be used 0 -means all available cores, can also be
#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, useMulti=useMulti, 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
......@@ -765,7 +780,7 @@ nCores=1, #number of cores to be used 0 -means all available cores, can also be
registerDoParallel(nCores)
}
nC<-getDoParWorkers()
oneRep<-function(i,M,n,k,mingr,maxgr,addParam,rep,nC,...){
oneRep<-function(i,M,approaches, blocks, n,k,mingr,maxgr,addParam,rep,nC,...){
if(printRep) cat("\n\nStarting optimization of the partiton",i,"of",rep,"partitions.\n")
temppar<-parGenFun(n=n,k=k,mingr=mingr,maxgr=maxgr,addParam=addParam)
......@@ -774,7 +789,7 @@ nCores=1, #number of cores to be used 0 -means all available cores, can also be
#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, useMulti=useMulti, 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)
......@@ -787,8 +802,8 @@ nCores=1, #number of cores to be used 0 -means all available cores, can also be
# nIter[i]<-res[[i]]$resC$nIter
return(list(tres))
}
pkgName<-utils::packageName(environment(optParC))
res<-foreach::foreach(i=1:rep,.combine=c, .packages=pkgName) %dorng% oneRep(i=i,M=M,n=n,k=k,mingr=mingr,maxgr=maxgr,addParam=addParam,rep=rep,nC=nC,...)
pkgName<-utils::packageName()
res<-foreach::foreach(i=1:rep,.combine=c, .packages=pkgName) %dorng% oneRep(i=i,M=M,approaches=approaches, blocks=blocks ,n=n,k=k,mingr=mingr,maxgr=maxgr,addParam=addParam,rep=rep,nC=nC,...)
err<-sapply(res,function(x)x$err)
nIter<-sapply(res,function(x)x$resC$nIter)
}
......
"IM" <-
function(res,which=1,...){
function(res,which=1, drop=TRUE, ...){
if(class(res)=="opt.more.par"){
return(res$best[[which]]$IM)
} else return(res$IM)
IM<-res$best[[which]]$IM
} else IM<-res$IM
if(drop)IM<-drop(IM)
return(IM)
}
"EM" <-
function(res,which=1, drop=TRUE,...){
if(class(res)=="opt.more.par"){
EM<-res$best[[which]]$EM
} else EM<-res$EM
if(drop)EM<-drop(EM)
return(EM)
}
......@@ -19,8 +19,7 @@ function(x = M, M = x, clu, ignore.diag = "default", sortNames = TRUE, FUN = "me
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)
} else ignore.diag <-identical(ss(diag(M)),0)&(nmode==1)
}
if(sortNames) {
......
......@@ -20,6 +20,7 @@ addParam = list(
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)
......
"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)){
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)]
......@@ -11,7 +11,7 @@
"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)){
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)]
......
......@@ -4,8 +4,9 @@ function(filename,useSparseMatrix=NULL,minN=50,safe=TRUE,closeFile=TRUE){
file<-file(description=filename,open="r")
} else file<-filename
while(TRUE){
line<-scan(file = file, nlines =1,what="char",quiet =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
}
......@@ -14,8 +15,9 @@ function(filename,useSparseMatrix=NULL,minN=50,safe=TRUE,closeFile=TRUE){
if(safe){
vnames<-rep(as.character(NA),n)
while(TRUE){
line<-scan(file = file, nlines =1,what="char",quiet =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]
......@@ -51,7 +53,7 @@ function(filename,useSparseMatrix=NULL,minN=50,safe=TRUE,closeFile=TRUE){
tmp<-as.matrix(tmp)
M[1:n,1:n]<-M
} else while(TRUE){
line<-scan(file = file, nlines =1,what="char",quiet =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)=="*"){
......@@ -59,22 +61,22 @@ function(filename,useSparseMatrix=NULL,minN=50,safe=TRUE,closeFile=TRUE){
next
}else line<-as.double(line)
if(type=="*Arcs"){
if(tolower(type)=="*arcs"){
M[line[1],line[2]]<-line[3]
}else if(type=="*Edges") {
}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{
} 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)
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)=="*"){
......@@ -111,7 +113,7 @@ function(filename,useSparseMatrix=NULL,minN=50,safe=TRUE,closeFile=TRUE){
tmp<-as.matrix(tmp)
M[1:n1,(n1+1):n12]<-tmp
} else while(TRUE){
line<-scan(file = file, nlines =1,what="char",quiet =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)=="*"){
......@@ -124,7 +126,8 @@ function(filename,useSparseMatrix=NULL,minN=50,safe=TRUE,closeFile=TRUE){
}
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)
}
......@@ -4,21 +4,19 @@ loadpajek<-function(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)
line<-scan(file = file, nlines =1,what="char",quiet =TRUE, blank.lines.skip=FALSE)
if(length(line)==0) {
nblanklines=nblanklines+1
if (nblanklines>10) break
next
break
}
nblanklines=0
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(line[1]=="*Matrix" || line[1]=="*Network"){
if(tolower(tolower(line[1]))=="*matrix" || tolower(line[1])=="*network"){
objName<-paste(line[-1],collapse=" ")
if(line[1]=="*Matrix"){
if(tolower(line[1])=="*matrix"){
readObj<-loadmatrix(file)
}else readObj<-loadnetwork2(file, closeFile=FALSE)
......@@ -32,10 +30,10 @@ loadpajek<-function(filename){
}
res[["Networks"]]<-c(res[["Networks"]],list(readObj))
names(res[["Networks"]])[length(res[["Networks"]])]<-objName
} else if(line[1]=="*Vector" || line[1]=="*Permutation" || line[1]=="*Partition"){
} else if(tolower(line[1])=="*vector" || tolower(line[1])=="*permutation" || tolower(line[1])=="*partition"){
objName<-paste(line[-1],collapse=" ")
readObj<-loadvector2(file)
if(line[1]=="*Vector"){
if(tolower(line[1])=="*vector"){
if(objName %in% names(res[["Vectors"]])){
i<-1
while(TRUE){
......@@ -46,7 +44,7 @@ loadpajek<-function(filename){
}
res[["Vectors"]]<-c(res[["Vectors"]],list(readObj))
names(res[["Vectors"]])[length(res[["Vectors"]])]<-objName
} else if(line[1]=="*Permutation"){
} else if(tolower(line[1])=="*permutation"){
if(objName %in% names(res[["Permutations"]])){
i<-1
while(TRUE){
......@@ -57,7 +55,7 @@ loadpajek<-function(filename){
}
res[["Permutations"]]<-c(res[["Permutations"]],list(readObj))
names(res[["Permutations"]])[length(res[["Permutations"]])]<-objName
} else if(line[1]=="*Partition"){
} else if(tolower(line[1])=="*partition"){
if(objName %in% names(res[["Partitions"]])){
i<-1
while(TRUE){
......
......@@ -2,8 +2,8 @@
structure(function(filename){
if(is.character(filename)) {file<-file(description=filename,open="r")
}else file<-filename
nn <-read.table(file=file,nrows=1)
while(nn[1]!="*vertices") nn <-read.table(file=file,nrows=1)
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]]
......
......@@ -57,15 +57,21 @@ function(
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?
printMultipliedMessage = TRUE, # shold mutiplication message be printed when values were the printed tie values are multiplied
replaceNAdiagWith0=TRUE, #Should the diagonal with only NAs be replace by 0s?
colLabels=FALSE, # Should the labels of units be colored. If FALSE, these are not collored, if TRUE, they are colored with colors of clusters as defined by palette. This can be aslo a vector of colors (or integers) for one-mode networks or a list of two such vectors for two-mode networks.
... #aditional arguments to plot.default
){
old.mar<-par("mar")
if(length(dim(IM))>2&use.IM){
if(length(dim(IM))>length(dim(IM))&use.IM){
if(is.null(wIM))wIM<-wnet
if(is.null(wIM)) wIM<-1
IM<-IM[wIM,,]
if(length(dim(IM))==3) {
IM<-IM[wIM,,]
} else{
warning("IM will not be used for plotting. Cannot be sure how to extract the appropirate part!")
use.IM<-FALSE
}
}
tempClu<-clu
......@@ -76,7 +82,7 @@ function(
relDim<-which.min(dim(M))
if(relDim==1){
M<-M[wnet,,]
}else if(relDim==1){
}else if(relDim==3){
M<-M[,,wnet]
}else stop("More than 2 dimensions where relation dimension can not be determined")
}else{
......@@ -169,6 +175,15 @@ function(
}
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)
......@@ -220,13 +235,16 @@ function(
dens<-dens[or.r,or.c]
}
if(cex.axes=="default"){ #defining the size of text on the axes
cex.x.axis<-min(15/dm[2],1)
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.x.axis<-cex.axes
cex.y.axis<-cex.axes
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
......@@ -293,8 +311,37 @@ function(
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 )
}
if(print.y.axis.val) text(x=y.axis.val.pos, y = (dm[1]:1)/dm[1]-1/dm[1]/2 +val.y.coor.cor,labels = yaxe,cex=cex.y.axis,adj=1)
if(print.x.axis.val) text(y=x.axis.val.pos, x = (1:dm[2])/dm[2]-1/dm[2]/2 +val.x.coor.cor, srt=90, labels = xaxe, cex=cex.x.axis,adj=0)
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))
......@@ -374,6 +421,7 @@ function(
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
){
......@@ -401,10 +449,12 @@ function(
relNames<-dimnames(M)[[relDim]]
if(is.null(relNames)) relNames<-1:nDim
for(iName in relNames) {
for(i in 1:nDim){
#for(iName in relNames)
iName<-relNames[i]
if(relDim==1){
plot.mat(M[iName,,],main=iName,...)
} else if(relDim==3) plot.mat(M[,,iName],main=iName,...)
plot.mat(M[iName,,],main=iName, IM=IM[i,,],...)
} else if(relDim==3) plot.mat(M[,,iName],main=iName, IM=IM[i,,],...)
}
title(main=main.title,outer=TRUE,line=main.title.line)
......
......@@ -10,6 +10,6 @@ function(
warning("The selected (",which,") best solution does not exist!\nOnly ", length(x$best)," best solution(s) exist(s).\nThe first best solution will be ploted.\n")
which<-1
}
plot.mat(x$M,clu=x$best[[which]]$clu,IM=x$best[[which]]$IM,main=main,...)
plot.mat(x$M,clu=clu(x,which=which),IM=x$best[[which]]$IM,main=main,...)
}
citHeader("To cite package '",meta$Package,"' in publications, please use package citation and (at least) one of the articles:", sep="")
citHeader("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)
......@@ -17,7 +17,7 @@ citEntry(entry = "Article",
year = "2007",
number = "1",
pages = "105--126",
textVersion= "Žiberna, A. (2007). Generalized blockmodeling of valued networks. Social Networks 29(1), 105-126."