Nothing
###{{{ labels
##' Define labels of graph
##'
##' Alters labels of nodes and edges in the graph of a latent variable model
##'
##'
##' @aliases labels<- labels labels<-.default labels.lvm labels.lvmfit
##' labels.graphNEL edgelabels edgelabels<- edgelabels<-.lvm nodecolor
##' nodecolor<- nodecolor<-.default
##' @author Klaus K. Holst
##' @export
##' @keywords graphs aplot
##' @examples
##' m <- lvm(c(y,v)~x+z)
##' regression(m) <- c(v,x)~z
##' labels(m) <- c(y=expression(psi), z=expression(zeta))
##' nodecolor(m,~y+z+x,border=c("white","white","black"),
##' labcol="white", lwd=c(1,1,5),
##' lty=c(1,2)) <- c("orange","indianred","lightgreen")
##' edgelabels(m,y~z+x, cex=c(2,1.5), col=c("orange","black"),labcol="darkblue",
##' arrowhead=c("tee","dot"),
##' lwd=c(3,1)) <- expression(phi,rho)
##' edgelabels(m,c(v,x)~z, labcol="red", cex=0.8,arrowhead="none") <- 2
##' \donttest{plot(m,addstyle=FALSE)}
##'
##' m <- lvm(y~x)
##' labels(m) <- list(x="multiple\nlines")
##' \donttest{
##' op <- par(mfrow=c(1,2))
##' plot(m,plain=TRUE)
##' plot(m)
##' par(op)
##' }
##'
##' \donttest{
##' d <- sim(m,100)
##' e <- estimate(m,d)
##' plot(e,type="sd")
##' }
##' @param object \code{lvm}-object.
##' @param value node label/edge label/color
##' @param to Formula specifying outcomes and predictors defining relevant
##' edges.
##' @param \dots Additional arguments (\code{lwd}, \code{cex}, \code{col},
##' \code{labcol}), \code{border}.
##' @param var Formula or character vector specifying the nodes/variables to
##' alter.
##' @param border Colors of borders
##' @param labcol Text label colors
##' @param shape Shape of node
##' @param lwd Line width of border
##' @usage
##' \method{labels}{default}(object, ...) <- value
##' \method{edgelabels}{lvm}(object, to, ...) <- value
##' \method{nodecolor}{default}(object, var=vars(object),
##' border, labcol, shape, lwd, ...) <- value
`labels<-` <- function(object,...,value) UseMethod("labels<-")
##' @export
`labels<-.default` <- function(object,...,value) {
labels(object,value)
}
##' @export
labels.graphNEL <- function(object,lab=NULL,...) {
if (is.null(lab))
return(graph::nodeRenderInfo(object)$label)
graph::nodeRenderInfo(object) <- list(label=lab)
names(graph::nodeRenderInfo(object)$label) <- graph::nodes(object);
return(object)
}
##' @export
labels.lvmfit <- function(object,lab=NULL,...) {
if (is.null(lab)) return(object$noderender$label)
object$noderender$label <- lab
return(object)
}
##' @export
`labels.lvm` <- function(object,lab=NULL,...) {
if (is.null(lab))
return(object$noderender$label)
if (is.null(object$noderender$label))
object$noderender$label <- lab
else
object$noderender$label[names(lab)] <- lab
return(object)
}
###}}} labels
###{{{ edgelabels
##' @export
"edgelabels<-.lvmfit" <- function(object,to,from,est=TRUE,edges=NULL,cex=1,...,value) {
if (is.null(edges)) {
if (class(to)[1]=="formula") {
yy <- decomp.specials(getoutcome(to))
from <- setdiff(all.vars(to),yy)
to <- yy
}
edges <- paste(from,to,sep="~")
}
edges. <- paste("\"", edges, "\"", sep="")
fromto <- edge2pair(edges)
val <- c()
for (i in 1:length(edges)) {
val <- c(val,
formatC(effects(object,from=fromto[[i]][1],to=fromto[[i]][2],silent=TRUE)$directef[[1]])
)
}
if (est)
mytext <- paste("c(", paste(paste(edges.,"=expression(",as.character(value),"==\"",val,"\")",sep=""),collapse=","),")")
else
mytext <- paste("c(", paste(paste(edges.,"=expression(",as.character(value),")",sep=""),collapse=","),")")
graph::edgeRenderInfo(Graph(object))$label <- eval(parse(text=mytext))
graph::edgeRenderInfo(Graph(object))$cex[edges] <- cex
return(object)
}
##' @export
edgelabels.lvmfit <- function(object,value,type,pthres,...) {
if (!missing(value)) {
edgelabels(object,...) <- value
return(object)
}
if (missing(type))
return(graph::edgeRenderInfo(Graph(object))$label)
Afix <- index(object)$A ## Matrix with fixed parameters and ones where parameters are free
Pfix <- index(object)$P ## Matrix with fixed covariance parameters and ones where param
npar.mean <- index(object)$npar.mean
Par <- object$coef
if (npar.mean>0)
Par <- Par[-seq_len(npar.mean),,drop=FALSE]
Par <-
switch(type,
sd = paste(formatC(Par[,1,drop=FALSE]), " (", formatC(Par[,2,drop=FALSE]), ")", sep=""),
est = formatC(Par[,1,drop=FALSE]),
pval = formatC(Par[,4,drop=FALSE]),
name = rownames(Par),
none = ""
)
AP <- matrices(Model(object), Par) ## Ignore expar
A <- AP$A; P <- AP$P
P[exogenous(object),exogenous(object)] <- NA
gr <- finalize(Model(object), ...)
Anz <- A; Anz[Afix==0] <- NA
gr <- edgelabels(gr, lab=Anz)
Pnz <- P; Pnz[Model(object)$cov==0] <- NA
gr <- edgelabels(gr, lab=Pnz)
Graph(object) <- gr
return(object)
}
##' @export
`edgelabels` <- function(object, ...) UseMethod("edgelabels")
##' @export
`edgelabels<-` <- function(object,...,value) UseMethod("edgelabels<-")
##' @export
`edgelabels<-.lvm` <- function(object,to,...,value) {
edgelabels(object,to=to, lab=value,...)
}
##' @export
`edgelabels<-.graphNEL` <- function(object,...,value) {
edgelabels(object,lab=value,...)
}
##' @export
`edgelabels.graphNEL` <- function(object, lab=NULL, to=NULL, from=NULL, cex=1.5, lwd=1, lty=1, col="black", labcol="black", arrowhead="closed",
expr=TRUE,
debug=FALSE,...) {
if (is.null(lab)) {
return(graph::edgeRenderInfo(object)$label)
}
if (class(to)[1]=="formula") {
yy <- decomp.specials(getoutcome(to))
from <- all.vars(to[[3]])##setdiff(all.vars(to),yy)
if (length(from)==0) from <- yy
to <- yy
}
M <- as(object, Class="matrix")
nodes <- graph::nodes(object)
if (is.null(graph::edgeRenderInfo(object)$label))
graph::edgeRenderInfo(object)$label <- expression()
if (!is.null(lab)) {
if (!is.null(from) & !is.null(to)) {
estr <- paste("\"",from,"~",to,"\"", sep="")
estr2 <- paste(from,"~",to, sep="")
if (length(lab)!=length(estr2)) lab <- rep(lab,length(estr2))
if (length(col)!=length(estr2)) col <- rep(col,length(estr2))
if (length(cex)!=length(estr2)) cex <- rep(cex,length(estr2))
if (length(lwd)!=length(estr2)) lwd <- rep(lwd,length(estr2))
if (length(lty)!=length(estr2)) lty <- rep(lty,length(estr2))
if (length(arrowhead)!=length(estr2))
arrowhead <- rep(arrowhead,length(estr2))
if (length(labcol)!=length(estr2))
labcol <- rep(labcol,length(estr2))
curedges <- names(graph::edgeRenderInfo(object)$label)
Debug(estr,debug)
estr2.idx <- which(estr2%in%curedges)
newstr.idx <- setdiff(1:length(estr2),estr2.idx)
newstr <- estr2[newstr.idx]
estr2 <- estr2[estr2.idx]
if (length(estr2)>0) {
if (!is.null(lab))
graph::edgeRenderInfo(object)$label[estr2] <- lab[estr2.idx]
if (!is.null(cex))
graph::edgeRenderInfo(object)$cex[estr2] <- cex[estr2.idx]
if (!is.null(col))
graph::edgeRenderInfo(object)$col[estr2] <- col[estr2.idx]
if (!is.null(lwd))
graph::edgeRenderInfo(object)$lwd[estr2] <- lwd[estr2.idx]
if (!is.null(lty))
graph::edgeRenderInfo(object)$lty[estr2] <- lty[estr2.idx]
if (!is.null(labcol))
graph::edgeRenderInfo(object)$textCol[estr2] <- labcol[estr2.idx]
if (!is.null(arrowhead))
graph::edgeRenderInfo(object)$arrowhead[estr2] <- arrowhead[estr2.idx]
}
if (length(newstr)>0) {
if (!is.null(lab))
graph::edgeDataDefaults(object)$futureinfo$label[newstr] <-
lab[newstr.idx]
if (!is.null(cex))
graph::edgeDataDefaults(object)$futureinfo$cex[newstr] <-
cex[newstr.idx]
if (!is.null(col))
graph::edgeDataDefaults(object)$futureinfo$col[newstr] <-
col[newstr.idx]
if (!is.null(lwd))
graph::edgeDataDefaults(object)$futureinfo$lwd[newstr] <-
lwd[newstr.idx]
if (!is.null(lty))
graph::edgeDataDefaults(object)$futureinfo$lty[newstr] <-
lty[newstr.idx]
if (!is.null(labcol))
graph::edgeDataDefaults(object)$futureinfo$textCol[newstr] <-
labcol[newstr.idx]
if (!is.null(arrowhead))
graph::edgeDataDefaults(object)$futureinfo$arrowhead[newstr] <-
arrowhead[newstr.idx]
}
return(object)
}
## Used by "edgelabels.lvmfit"
for (r in 1:nrow(M))
for (s in 1:ncol(M)) {
if (M[r,s]!=0 & !is.na(lab[r,s])) {
estr <- paste("\"",nodes[r],"~",nodes[s],"\"", sep="")
estr2 <- paste(nodes[r],"~",nodes[s], sep="")
Debug(estr, debug)
if (expr)
st <- eval(parse(text=paste("expression(",lab[r,s],")",sep="")))
else
st <- lab[r,s]
graph::edgeRenderInfo(object)$label[estr2] <- st
}
}
}
return(object)
}
##' @export
`edgelabels.lvm` <- function(object, lab=NULL, to=NULL, from=NULL,
cex=1.5, lwd=1, lty=1, col="black",
labcol="black", arrowhead="closed",
expr=TRUE, debug=FALSE,...) {
if (is.null(lab)) {
return(object$edgerender$label)
}
if (class(to)[1]=="formula") {
yy <- decomp.specials(getoutcome(to))
from <- all.vars(to[[3]])##setdiff(all.vars(to),yy)
if (length(from)==0) from <- yy
to <- yy
}
M <- object$M
nodes <- colnames(M)
if (is.null(object$edgerender$label))
object$edgerender$label <- expression()
if (!is.null(lab)) {
if (!is.null(from) & !is.null(to)) {
estr <- paste("\"",from,"~",to,"\"", sep="")
estr2 <- paste(from,"~",to, sep="")
if (length(lab)!=length(estr2)) lab <- rep(lab,length(estr2))
if (length(col)!=length(estr2)) col <- rep(col,length(estr2))
if (length(cex)!=length(estr2)) cex <- rep(cex,length(estr2))
if (length(lwd)!=length(estr2)) lwd <- rep(lwd,length(estr2))
if (length(lty)!=length(estr2)) lty <- rep(lty,length(estr2))
if (length(labcol)!=length(estr2)) labcol <- rep(labcol,length(estr2))
if (length(arrowhead)!=length(estr2)) arrowhead <- rep(arrowhead,length(estr2))
curedges <- names(object$edgerender$label)
Debug(estr,debug)
estr2.idx <- which(estr2%in%curedges)
newstr.idx <- setdiff(1:length(estr2),estr2.idx)
newstr <- estr2[newstr.idx]
estr2 <- estr2[estr2.idx]
if (length(estr2)>0) {
if (!is.null(lab))
object$edgerenderlabel[estr2] <- lab[estr2.idx]
if (!is.null(cex))
object$edgerender$cex[estr2] <- cex[estr2.idx]
if (!is.null(col))
object$edgerender$col[estr2] <- col[estr2.idx]
if (!is.null(lwd))
object$edgerender$lwd[estr2] <- lwd[estr2.idx]
if (!is.null(lty))
object$edgerender$lty[estr2] <- lty[estr2.idx]
if (!is.null(labcol))
object$edgerender$textCol[estr2] <- labcol[estr2.idx]
if (!is.null(arrowhead))
object$edgerender$arrowhead[estr2] <- arrowhead[estr2.idx]
}
if (length(newstr)>0) {
if (!is.null(lab))
object$edgerender$futureinfo$label[newstr] <-
lab[newstr.idx]
if (!is.null(cex))
object$edgerender$futureinfo$cex[newstr] <-
cex[newstr.idx]
if (!is.null(col))
object$edgerender$futureinfo$col[newstr] <-
col[newstr.idx]
if (!is.null(lwd))
object$edgerender$futureinfo$lwd[newstr] <-
lwd[newstr.idx]
if (!is.null(lty))
object$edgerender$futureinfo$lty[newstr] <-
lty[newstr.idx]
if (!is.null(labcol))
object$edgerender$futureinfo$textCol[newstr] <-
labcol[newstr.idx]
if (!is.null(arrowhead))
object$edgerender$futureinfo$arrowhead[newstr] <-
arrowhead[newstr.idx]
}
return(object)
}
## Used by "edgelabels.lvmfit"
for (r in 1:nrow(M))
for (s in 1:ncol(M)) {
if (M[r,s]!=0 & !is.na(lab[r,s])) {
estr <- paste("\"",nodes[r],"~",nodes[s],"\"", sep="")
estr2 <- paste(nodes[r],"~",nodes[s], sep="")
Debug(estr, debug)
if (expr)
st <- eval(parse(text=paste("expression(",lab[r,s],")",sep="")))
else
st <- lab[r,s]
object$edgerender$label[estr2] <- st
}
}
}
return(object)
}
###}}} edgelabels
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.