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

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