Nothing
# jonashaslbeck@gmail.com; March 2016
FactorGraph <- function(object,
labels,
PairwiseAsEdge = FALSE,
Nodewise = FALSE,
DoNotPlot = FALSE,
FactorLabels = TRUE,
colors,
shapes,
shapeSizes = c(8, 4),
estpoint = NULL,
negDashed = FALSE,
...)
{
# --------- Compute Aux Variables ---------
if(Nodewise) PairwiseAsEdge <- FALSE
p <- length(object$call$level)
n_estpoints <- length(object$call$estpoints)
# --------- Input Checks ---------
if(!missing(labels)) if(length(labels) != p) stop("Number of provided labels has to match the number of variables.")
# Checks for time-varying FactorGraph
if("tvmgm" %in% class(object)) {
if(missing(estpoint)) stop("Specify the estimation point for which the factor graph should be visualized.")
if(estpoint > n_estpoints) stop(paste0("The provided fit object has only ", n_estpoints, " estimation points."))
}
if(object$call$k > 4) stop("Please specify additional colors/shapes for interactions with order > 4.")
# --------- Create FractorGraph object ---------
call <- list("object" = object)
FG_object <- list("call" = call,
"graph" = NULL,
"nodetype" = NULL,
"order" = NULL,
"signs" = NULL,
"edgecolor" = NULL,
"nonzero" = NULL,
"qgraph" = NULL)
# --------- Fill in defaults ---------
if(missing(labels)) labels <- 1:p
if(missing(colors)) colors <- c("white", "tomato", "lightblue", "orange")
if(missing(shapes)) shapes <- c("circle", "square", "triangle", "diamond")
layout <- "circle"
cut <- 0
# --------- Compute Factor Graph ----------
# Call different DrawFG() version for stationary/time-varying
if("tvmgm" %in% class(object)) {
# Time-varying
FG <- DrawFGtv(object = object,
PairwiseAsEdge = PairwiseAsEdge,
Nodewise = Nodewise,
estpoint = estpoint)
} else {
# Stationary
FG <- DrawFG(object = object,
PairwiseAsEdge = PairwiseAsEdge,
Nodewise = Nodewise)
}
# Save into FG_object
FG_object$graph <- FG$weightedgraph
FG_object$nodetype <- FG$nodetype
FG_object$order <- FG$order
FG_object$signs <- FG$signs
FG_object$edgecolor <- edge.color <- FG$signcolor
FG_object$nonzero <- FG$nonzero
# Allow overwriting ...
args <- list(...)
if(!is.null(args$cut)) cut <- args$cut
if(!is.null(args$layout)) layout <- args$layout
if(!is.null(args$edge.color)) edge.color <- args$edge.color
# browser()
# Adapt edge labels for zero edges in Nodewise=TRUE
if(!is.null(args$edge.labels)) { # if specified, otherwise set to FALSE
if(is.logical(args$edge.labels)) { # if specified and logical, then adapt for nonzero or FALSE
if(args$edge.labels) {
edge.labels <- FG_object$graph
edge.labels[FG_object$nonzero == 2] <- 0
edge.labels <- round(edge.labels, 2)
} else {
edge.labels = FALSE
}
} else {
# if not logical, take the input
edge.labels <- args$edge.labels
}
} else {
edge.labels = FALSE
}
# Edge lty: allow negative edges to be dashed for greyscale images
edge_lty <- FG_object$nonzero
if(negDashed) edge_lty[edge.color == "red"] <- 2
# --------- Plot & Return ---------
if(!DoNotPlot){
# ----- Compute stuff necessary for plotting -----
# Create labels for factors (label = order of factor/interaction)
ifelse(PairwiseAsEdge, ek <- 1, ek <- 0)
if(FactorLabels) {
tb <- table(FG_object$order)[-1]
if(length(tb)==0) { # For the case PairwiseAsEdge=FALSE and no 3-way interactions
FL <- NULL
} else {
l_lf <- list()
for(k in 1:length(tb)) l_lf[[k]] <- rep(k+1+ek, tb[k])
FL <- unlist(l_lf)
}
labels_ex <- c(labels, FL)
} else {
labels_ex <- c(labels, rep('', sum(FG_object$nodetype)))
}
# ----- Call qgraph -----
qgraph_object <- qgraph(FG_object$graph,
color = colors[FG_object$order + 1],
edge.color = edge.color,
lty = edge_lty,
layout = layout,
labels = labels_ex,
shape = shapes[FG_object$order + 1],
vsize = shapeSizes[FG_object$nodetype + 1],
edge.labels = edge.labels,
cut = cut,
...)
FG_object$qgraph <- qgraph_object
invisible(FG_object) # return output object invisible
} else {
return(FG_object)
}
} # eoF
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.