1##' @export 2`finalize` <- 3 function(x,...) UseMethod("finalize") 4 5##' @export 6`finalize.lvm` <- 7 function(x, diag=FALSE, cor=FALSE, addcolor=TRUE, intercept=FALSE, plain=FALSE, cex, fontsize1=10, cols=lava.options()$node.color, unexpr=FALSE, addstyle=TRUE, ...) { 8 9 g <- as(new("graphAM",adjMat=x$M,"directed"),"graphNEL") 10 graph::nodeRenderInfo(g)$fill <- NA 11 graph::nodeRenderInfo(g)$label <- NA 12 graph::nodeRenderInfo(g)$label[vars(x)] <- vars(x) 13 graph::nodeRenderInfo(g)$shape <- x$graphdef$shape 14 15 Lab <- NULL 16 for (i in seq_len(length(x$noderender))) { 17 nn <- unlist(x$noderender[[i]]) 18 if (length(nn)>0) { 19 R <- list(as.list(x$noderender[[i]])); names(R) <- names(x$noderender)[i] 20 if (names(x$noderender)[i]!="label") 21 graph::nodeRenderInfo(g) <- x$noderender[i] 22 else Lab <- R[[1]] 23 } 24 } 25 26 if (!is.null(Lab)) { ## Ugly hack to allow mathematical annotation 27 nn <- names(graph::nodeRenderInfo(g)$label) 28 LL <- as.list(graph::nodeRenderInfo(g)$label) 29 LL[names(Lab)] <- Lab 30 if (any(unlist(lapply(LL,function(x) is.expression(x) || is.name(x) || is.call(x))))) { 31 graph::nodeRenderInfo(g) <- list(label=as.expression(LL)) 32 } else graph::nodeRenderInfo(g) <- list(label=LL) 33 names(graph::nodeRenderInfo(g)$label) <- nn 34 ii <- which(names(graph::nodeRenderInfo(g)$label)=="") 35 if (length(ii)>0) 36 graph::nodeRenderInfo(g)$label <- graph::nodeRenderInfo(g)$label[-ii] 37 } 38 39 graph::edgeDataDefaults(g)$futureinfo <- x$edgerender$futureinfo 40 graph::edgeRenderInfo(g)$lty <- x$graphdef$lty 41 graph::edgeRenderInfo(g)$lwd <- x$graphdef$lty 42 graph::edgeRenderInfo(g)$col <- x$graphdef$col 43 graph::edgeRenderInfo(g)$textCol <- x$graphdef$textCol 44 graph::edgeRenderInfo(g)$arrowhead <- x$graphdef$arrowhead 45 graph::edgeRenderInfo(g)$dir <- x$graphdef$dir 46 graph::edgeRenderInfo(g)$arrowtail <- "none" 47 graph::edgeRenderInfo(g)$cex <- x$graphdef$cex 48 graph::edgeRenderInfo(g)$label <- x$graphdef$label 49 for (i in seq_len(length(x$edgerender))) { 50 ee <- x$edgerender[[i]] 51 if (length(ee)>0 && names(x$edgerender)[i]!="futureinfo") { 52 graph::edgeRenderInfo(g)[names(x$edgerender)[i]][names(ee)] <- ee 53 } 54 } 55 56 opt <- options(warn=-1) 57 var <- rownames(covariance(x)$rel) 58 59 60 if (unexpr) { 61 mylab <- as.character(graph::edgeRenderInfo(g)$label); names(mylab) <- names(graph::edgeRenderInfo(g)$label) 62 g@renderInfo@edges$label <- as.list(mylab) 63 } 64 65 66 if (intercept) { 67 ## mu <- intfix(x) 68 ## nNA <- sum(is.na(mu)) 69 ## if (nNA>0) 70 ## mu[is.na(mu)] <- paste("m",seq_len(nNA)) 71 ## mu <- unlist(mu) 72 ## x <- addNode(mu,x) 73 ## for (i in seq_along(mu)) { 74 ## print(mu[i]) 75 ## x <- addEdge(var[i], var[i], x) 76 ## } 77 ## x <- addattr(x,attr="shape",var=mu,val="none") 78 } 79 80 allEdges <- graph::edgeNames(g) 81 regEdges <- c() 82 feedback <- c() 83 A <- index(x)$A 84 if (index(x)$npar.reg>0) 85 for (i in seq_len(nrow(A)-1)) 86 for (j in (i+1):(ncol(A))) { 87 if(A[i,j]==1 & A[j,i]==1) feedback <- c(feedback, 88 paste0(var[i],"~",var[j]), 89 paste0(var[j],"~",var[i])) 90 if (A[j,i]==0 & x$M[j,i]!=0) { 91 g <- graph::removeEdge(var[j],var[i],g) 92 } 93 if (A[i,j]==1) regEdges <- c(regEdges,paste0(var[i],"~",var[j])) 94 if (A[j,i]==1) regEdges <- c(regEdges,paste0(var[j],"~",var[i])) 95 } 96 97 98 varEdges <- corEdges <- c() 99 delta <- ifelse(diag,0,1) 100 if (cor | diag) { 101 for (r in seq_len(nrow(covariance(x)$rel)-delta) ) { 102 for (s in (r+delta):ncol(covariance(x)$rel) ) { 103 if (cor | r==s) 104 if (covariance(x)$rel[r,s]==1 & (!any(c(var[r],var[s])%in%exogenous(x)))) { 105 newedges <- c() 106 if (A[r,s]!=1) { 107 g <- graph::addEdge(var[r],var[s], g) 108 newedges <- paste0(var[r],"~",var[s]) 109 } else { 110 if (A[s,r]!=1) { 111 g <- graph::addEdge(var[s],var[r], g) 112 newedges <- c(newedges,paste0(var[s],"~",var[r])) 113 } 114 } 115 if (r==s) 116 varEdges <- c(varEdges, 117 newedges 118 ) 119 if (r!=s) 120 corEdges <- c(corEdges,newedges) 121 } 122 } 123 } 124 } 125 126 if (length(x$edgerender$futureinfo)>0) { 127 estr <- names(x$edgerender$futureinfo$label) 128 estr <- estr[which(unlist(lapply(estr,nchar))>0)] 129 revestr <- sapply(estr, function(y) paste(rev(unlist(strsplit(y,"~"))),collapse="~")) 130 revidx <- which(revestr%in%graph::edgeNames(g)) 131 count <- 0 132 for (i in estr) { 133 count <- count+1 134 for (f in names(x$edgerender$futureinfo)) { 135 if (count%in%revidx) { 136 g@renderInfo@edges[[f]][[revestr[count]]] <- x$edgerender$futureinfo[[f]][[i]] 137 } else { 138 g@renderInfo@edges[[f]][[i]] <- x$edgerender$futureinfo[[f]][[i]] 139 } 140 } 141 } 142 } 143 allEdges <- unique(c(regEdges,corEdges,varEdges)) 144 corEdges <- setdiff(corEdges,regEdges) 145 146 for (e in allEdges) { 147 dir <- "forward"; lty <- 1; arrowtail <- "none" 148 if (e %in% feedback) { 149 dir <- "none"; lty <- 1; arrowtail <- "closed" 150 } 151 if (e %in% varEdges) { 152 dir <- "none"; lty <- 2; arrowtail <- "none" 153 } 154 if (e %in% corEdges) { 155 dir <- "none"; lty <- 2; arrowtail <- "closed" 156 } 157 arrowhead <- "closed" 158 estr <- e 159 for (f in c("col","cex","textCol","lwd","lty")) { 160 if (!(estr%in%names(graph::edgeRenderInfo(g)[[f]])) 161 || is.na(graph::edgeRenderInfo(g)[[f]][[estr]])) 162 g <- addattr(g,f,var=estr, 163 val=x$graphdef[[f]], 164 fun="graph::edgeRenderInfo") 165 } 166 167 if (addstyle) { 168 g <- addattr(g,"lty",var=estr,val=lty,fun="graph::edgeRenderInfo") 169 g <- addattr(g,"direction",var=estr,val=dir,fun="graph::edgeRenderInfo") 170 g <- addattr(g,"dir",var=estr,val=dir,fun="graph::edgeRenderInfo") 171 g <- addattr(g,"arrowhead",var=estr,val=arrowhead,fun="graph::edgeRenderInfo") 172 g <- addattr(g,"arrowtail",var=estr,val=arrowtail,fun="graph::edgeRenderInfo") 173 g <- addattr(g,attr="fontsize",var=estr,val=fontsize1,fun="graph::edgeRenderInfo") 174 } 175 if (is.null(graph::edgeRenderInfo(g)$label)) 176 graph::edgeRenderInfo(g)$label <- expression() 177 178 if (!missing(cex)) 179 if (!is.null(cex)) 180 graph::nodeRenderInfo(g)$cex <- cex 181 } 182 if (plain) { 183 g <- addattr(g,attr="shape",var=vars(x),val="none") 184 } else { 185 if (addcolor) { 186 if (is.null(x$noderender$fill)) notcolored <- vars(x) 187 else notcolored <- vars(x)[is.na(x$noderender$fill)] 188 nodecolor(g, intersect(notcolored,exogenous(x))) <- cols[1] 189 nodecolor(g, intersect(notcolored,endogenous(x))) <- cols[2] 190 nodecolor(g, intersect(notcolored,latent(x))) <- cols[3] 191 if (!is.null(trv <- x$attributes$transform)) { 192 nodecolor (g, names(trv)) <- cols[4] 193 } 194 ## nodecolor(x, intersect(notcolored,survival(x))) <- cols[4] 195 myhooks <- gethook("color.hooks") 196 count <- 3 197 for (f in myhooks) { 198 count <- count+1 199 res <- do.call(f, list(x=x,subset=notcolored)) 200 if (length(cols)>=count) { 201 nodecolor(g,res$vars) <- cols[count] 202 } else { 203 nodecolor(g, res$vars) <- res$col 204 } 205 } 206 } 207 } 208 options(opt) 209 attributes(g)$feedback <- (length(feedback)>0) 210 return(g) 211 } 212