git.oblomov.eu Git - ohcount/blob - test/src_dir/example.R

   1 # Build a 'graph-like' object having 'nodes' nodes belonging to 'classes' classes.
   2 # Class distribution is given by 'proba', and connectivity probabilities are given
   3 # by 'intraproba' and 'interproba'.
   4 generateGraph<-function(nodes,classes,proba=rep(1/classes,classes),
   5                         intraproba=0.1,crossproba=0.02)
   6 {
   7         mat_pi=CreateConnectivityMat(classes,intraproba,crossproba)
   8         igraph=Fast2SimuleERMG(nodes,proba,mat_pi[1],mat_pi[2])
   9         adjacency=get.adjacency(igraph$graph)
  10         cmgraph=list(nodes=nodes,classes=classes,adjacency=adjacency,nodeclasses=igraph$node.classes,proba=proba,
  11                      intraproba=intraproba,crossproba=crossproba)
  12         attr(cmgraph,'class')<-c('cmgraph')
  13         cmgraph
  14 }
  15
  16 # Return explicit member names for the different attributes of graph objects.
  17 labels.cmgraph<-function(object,...)
  18 {
  19         c("Nodes","Classes","Adjacency Matrix","Node Classification","Class Probability Distribution","Intra Class Edge Probability","Cross Class Edge Probability")
  20 }
  21
  22 # Override the summmary function for graph objects.
  23 summary.cmgraph<-function(object,...)
  24 {
  25
  26         cat(c("Nodes                         : ",object$nodes,"\n",
  27               "Edges                         : ",length(which(object$adjacency!=0)),"\n",
  28               "Classes                       : ",object$classes,"\n",
  29               "Class Probability Distribution: ",object$proba,"\n"))
  30 }
  31
  32 # Override the plot function for graph objects.
  33 plot.cmgraph<-function(x,...)
  34 {
  35         RepresentationXGroup(x$adjacency,x$nodeclasses)
  36 }
  37
  38 # Generate covariable data for the graph 'g'. Covariables are associated to vertex data, and
  39 # their values are drawn according to 2 distributions: one for vertices joining nodes of
  40 # the same class, and another for vertices joining nodes of different classes.
  41 # The two distributions have different means but a single standard deviation.
  42 generateCovariablesCondZ<-function(g,sameclustermean=0,otherclustermean=2,sigma=1)
  43 {
  44         mu=CreateMu(g$classes,sameclustermean,otherclustermean)
  45         res=SimDataYcondZ(g$nodeclasses,mu,sigma)
  46         cmcovars=list(graph=g,sameclustermean=sameclustermean,otherclustermean=otherclustermean,sigma=sigma,mu=mu,y=res)
  47         attr(cmcovars,'class')<-c('cmcovarz','cmcovar')
  48         cmcovars
  49 }
  50
  51 # Generate covariable data for the graph 'g'. Covariables are associated to vertex data, and
  52 # their values are drawn according to 2 distributions: one for vertices joining nodes of
  53 # the same class, and another for vertices joining nodes of different classes.
  54 # The two distributions have different means but a single standard deviation.
  55 # This function generates two sets of covariables.
  56 generateCovariablesCondXZ<-function(g,sameclustermean=c(0,3),otherclustermean=c(2,5),sigma=1)
  57 {
  58         mux0=CreateMu(g$classes,sameclustermean[1],otherclustermean[1])
  59         mux1=CreateMu(g$classes,sameclustermean[2],otherclustermean[2])
  60         res=SimDataYcondXZ(g$nodeclasses,g$adjacency,mux0,mux1,sigma)
  61         cmcovars=list(graph=g,sameclustermean=sameclustermean,otherclustermean=otherclustermean,sigma=sigma,mu=c(mux0,mux1),y=res)
  62         attr(cmcovars,'class')<-c('cmcovarxz','cmcovar')
  63         cmcovars
  64 }
  65
  66
  67 # Override the print function for a cleaner covariable output.
  68 print.cmcovar<-function(x,...)
  69 {
  70         cat("Classes           : ",x$graph$classes,"\n",
  71             "Intra cluster mean: ",x$sameclustermean,"\n",
  72             "Cross cluster mean: ",x$otherclustermean,"\n",
  73             "Variance          : ",x$sigma,"\n",
  74             "Covariables       :\n",x$y,"\n")
  75 }
  76
  77
  78 # Perform parameter estimation on 'graph' given the covariables 'covars'.
  79 estimateCondZ<-function(graph,covars,maxiterations,initialclasses,selfloops)
  80 {
  81         res=EMalgorithm(initialclasses,covars$y,graph$adjacency,maxiterations,FALSE,selfloops)
  82         cmestimation=list(mean=res$MuEstimated,variance=res$VarianceEstimated,pi=res$PIEstimated,alpha=res$AlphaEstimated,tau=res$TauEstimated,jexpected=res$EJ,graph=graph)
  83         attr(cmestimation,'class')<-c('cmestimationz')
  84         cmestimation
  85 }
  86
  87 # Private generic estimation function used to allow various call conventions for estimation functions.
  88 privateestimate<-function(covars,graph,maxiterations,initialclasses,selfloops,...) UseMethod("privateestimate")
  89
  90 # Private estimation function used to allow various call conventions for estimation functions.
  91 # Override of generic function for single covariables.
  92 privateestimate.cmcovarz<-function(covars,graph,maxiterations,initialclasses,selfloops,...)
  93 {
  94         res=estimateCondZ(graph,covars,maxiterations,initialclasses,selfloops)
  95         attr(res,'class')<-c(attr(res,'class'),'cmestimation')
  96         res
  97
  98 }
  99
 100 # Perform parameter estimation on 'graph' given the covariables 'covars'.
 101 estimateCondXZ<-function(graph,covars,maxiterations,initialclasses,selfloops)
 102 {
 103         #resSimXZ = EMalgorithmXZ(TauIni,Y2,Adjacente,30,SelfLoop=FALSE)
 104         res=EMalgorithmXZ(initialclasses,covars$y,graph$adjacency,maxiterations,selfloops)
 105         cmestimation=list(mean=c(res$MuEstimated1,res$MuEstimated2),variance=res$VarianceEstimated,pi=res$PIEstimated,alpha=res$AlphaEstimated,tau=res$TauEstimated,jexpected=res$EJ,graph=graph)
 106         attr(cmestimation,'class')<-c('cmestimationxz')
 107         cmestimation
 108 }
 109
 110 # Private estimation function used to allow various call conventions for estimation functions.
 111 # Override of generic function for multiple covariables.
 112 privateestimate.cmcovarxz<-function(covars,graph,maxiterations,initialclasses,selfloops,...)
 113 {
 114         res=estimateCondXZ(graph,covars,maxiterations,initialclasses,selfloops)
 115         attr(res,'class')<-c(attr(res,'class'),'cmestimation')
 116         res
 117 }
 118
 119 # Generic estimation function applicable to graphs with covariables.
 120 estimate<-function(graph,covars,...) UseMethod("estimate")
 121
 122 # Override of the generic estimation function. Performs the actual function dispatch depending on the class of covariables.
 123 estimate.cmgraph<-function(graph,covars,maxiterations=20,initialclasses=t(rmultinom(size=1,prob=graph$proba,n=graph$nodes)),selfloops=FALSE,method=NULL,...)
 124 {
 125         if (length(method)  == 0) {
 126                 res=privateestimate(covars,graph,maxiterations,initialclasses,selfloops,...)
 127         } else {
 128                 res=method(graph,covars,maxiterations,initialclasses,selfloops)
 129                 attr(res,'class')<-c(attr(res,'class'),'cmestimation')
 130         }
 131         res
 132 }
 133
 134 # Override of the generic pliot function for estimation results.
 135 plot.cmestimation<-function(x,...)
 136 {
 137         par(mfrow = c(1,2))
 138         plot(x$jexpected)
 139         title("Expected value of J: Convergence criterion")
 140
 141         map=MAP(x$tau)
 142         gplot(x$graph$adjacency,vertex.col=map$node.classes+2)
 143         title("Network with estimated classes")
 144
 145 }
 146
 147 # Generic private ICL computation function for graphs and covariables.
 148 privatecomputeICL<-function(covars,graph,qmin,qmax,loops,maxiterations,selfloops) UseMethod("privatecomputeICL")
 149
 150
 151 # Private ICL computation function for graphs with single covariables.
 152 privatecomputeICL.cmcovarz<-function(covars,graph,qmin,qmax,loops,maxiterations,selfloops)
 153 {
 154         res=ICL(X=graph$adjacency,Y=covars$y,Qmin=qmin,Qmax=qmax,loop=loops,NbIteration=maxiterations,SelfLoop=selfloops,Plot=FALSE)
 155         attr(res,'class')<-c('cmiclz')
 156         res
 157
 158 }
 159
 160 # Private ICL computation function for graphs with multiple covariables.
 161 privatecomputeICL.cmcovarxz<-function(covars,graph,qmin,qmax,loops,maxiterations,selfloops)
 162 {
 163         res=ICL(X=graph$adjacency,Y=covars$y,Qmin=qmin,Qmax=qmax,loop=loops,NbIteration=maxiterations,SelfLoop=selfloops,Plot=FALSE)
 164         attr(res,'class')<-c('cmiclxz')
 165         res
 166 }
 167
 168
 169 # Generic public ICL computation function applicable to graph objects.
 170 computeICL<-function(graph,covars,qmin,qmax,...) UseMethod("computeICL")
 171
 172 # Override of ICL computation function applicable to graph objects.
 173 # Performs the actual method dispatch to private functions depending on the type of covariables.
 174 computeICL.cmgraph<-function(graph,covars,qmin,qmax,loops=10,maxiterations=20,selfloops=FALSE,...)
 175 {
 176         res=privatecomputeICL(covars,graph,qmin,qmax,loops,maxiterations,selfloops)
 177         res$qmin=qmin
 178         res$qmax=qmax
 179         res$graph=graph
 180         res$covars=covars
 181         attr(res,'class')<-c(attr(res,'class'),'cmicl')
 182         res
 183 }
 184
 185 # Override of the plot function for results of ICL computation.
 186 plot.cmicl<-function(x,...)
 187 {
 188         par(mfrow = c(1,2))
 189         result=x$iclvalues
 190         maxi=which(max(result)==result)
 191         plot(seq(x$qmin,x$qmax),result,type="b",xlab="Number of classes",ylab="ICL value")
 192         points(maxi+x$qmin-1,result[maxi],col="red")
 193         title("ICL curve")
 194         best=x$EMestimation[[maxi+x$qmin-1]]
 195         tau=best$TauEstimated
 196         map=MAP(tau)
 197         gplot(x$graph$adjacency,vertex.col=map$node.classes+2)
 198         title("Network with estimated classes")
 199 }
 200