Class dg.Model
An example class for the model object of dynamicGraph.
name |
Text string with the |
An object of class dg.Model.
This is an example of the object for interface between
dynamicGraphMain and your models.
The model object of the call of dynamicGraphMain
should have the methods modifyModel, testEdge,
graphEdges and setGraphEdges.
When the graph is modified, by adding or dropping vertices or edge,
the method modifyModel is called on the argument object
of dynamicGraphMain.
If a value different from NULL is returned from modifyModel at the
key event "add edge" then the edge is added to the the view of the model,
the graph window.
If NULL is returned from modifyModel then the methods
addModel and replaceModel
can be used to draw the new graph inside modifyModel.
If a value different from NULL is returned from modifyModel then
the methods addView ,addModel,
replaceView, and replaceModel
should not be called from modifyModel for the action add edge.
If the edge is to be added in a slave window then the edges to
draw can be returned in a component with name edgeList (or
newEdges$vertexEdges) of the returned structure.
If an object is returned in the list of the returned
value from modifyModel then object in
dynamicGraphMain is replaced by this object
(and the object is also assigned in the top level environment,
if objectName was given to dynamicGraphMain).
If a factor edge is added then the component edgeList with the
edges of the new model should be available in the returned structure.
New factor edges and factor vertices should also be avaliable in the
components FactorEdges and FactorVertices.
Similar for the key events "dropEdge", "addVertex" and "dropVertex".
The methods graphEdges and setGraphEdges
are used to communicate the graph components between several views
of the same model in dynamicGraphMain.
The method graphEdges of the model object is for returning
an object of class dg.graphedges-class
to draw in the view, depending on the viewType.
[[ UPDATE:
If NULL is returned for a component in the returned list
from graphEdges then the corresponding value of
Arguments is used in redrawView.
To force an empty list, return the value list()
(or numeric(0) for VisibleVertices
and VisibleBlocks). See also the argument
factorVertexList of drawModel. ]]
The method setGraphEdges of the model object
is called on the model object when the model is modified.
The methods testEdge of object should return
an object with the methods label and width
for labeling edges, see dg.Test-class.
dg:Object of class "dg.graphedges":
The graphedges of the model.
name:Object of class "character":
The name of the model.
signature(object = "dg.Model"): ...
signature(object = "dg.Model"): ...
signature(.Object = "dg.Model"): ...
signature(object = "dg.Model"): ...
signature(object = "dg.Model"): ...
signature(object = "dg.Model"): ...
Jens Henrik Badsberg
CoCo, with a guide at http://www.jstatsoft.org/v06/i04/,
has an interface to dynamicGraph.
# Part of the example "defaultObjects" of demo:
# Edit the following to meet your needs:
#
# - Change the name "your.Model"
#
# - Work out how the get names, types and edges from your model object.
#
# - At "message", insert the relevant code for testing and modifying the model.
#
# - The slots visibleVertices, visibleBlocks, extraVertices, edges,
# blockEdges, factorVertices, factorEdges should be eliminated,
# and you should in "graphEdges" return relevant lists.
#
setClass("your.Model",
representation(name = "character",
dg = "dg.graphedges"))
# "newDefaultModelObject"<-
# function(name)
# {
# result <- new("your.Model", name = name, dg = new("dg.graphedges"))
# return(result)
# }
setMethod("setSlots", "your.Model",
function(object, arguments) {
for (i in seq(along = arguments)) {
name <- names(arguments)[i]
if (is.element(name, slotNames(object)))
slot(object, name) <- arguments[[i]]
else
message(paste("Argument '", name, "' not valid slot of '",
class(object), "', thus ignored.",
sep = "")) }
return(object)
})
setMethod("initialize", "your.Model",
function(.Object, ...) {
# print(c("initialize", "your.Model", class(.Object)))
Args <- list(...)
.Object <- setSlots(.Object, Args)
return(.Object)
}
)
setMethod("graphEdges", "your.Model",
function(object, viewType = NULL, ...)
{ # print(viewType); print ("graphEdges")
dots <- list(...)
localArguments <- dots$Arguments
Vertices <- localArguments$vertexList
Edges <- object@dg@edgeList
VisibleVertices <- object@dg@visibleVertices
if (viewType == "Factor") {
factors <- .cliquesFromEdges(Edges, Vertices, VisibleVertices)
# print(factors)
if (is.null(factors) || (length(factors) == 0)) {
FactorVertices <- new("dg.FactorVertexList")
FactorEdges <- new("dg.FactorEdgeList")
} else {
result <- returnFactorVerticesAndEdges(Vertices, factors)
FactorVertices <- result$FactorVertices
FactorEdges <- result$FactorEdges
}
new("dg.graphedges",
viewType = viewType,
oriented = object@dg@oriented,
edgeList = object@dg@edgeList,
blockEdgeList = object@dg@blockEdgeList,
factorVertexList = FactorVertices,
factorEdgeList = FactorEdges,
visibleVertices = object@dg@visibleVertices,
visibleBlocks = object@dg@visibleBlocks,
extraList = object@dg@extraList,
extraEdgeList = object@dg@extraEdgeList)
} else if (viewType == "Moral") {
message("Moral view not implemented; ")
new("dg.graphedges",
viewType = viewType,
oriented = object@dg@oriented,
edgeList = object@dg@edgeList,
# blockEdgeList = new("dg.BlockEdgeList"),
# factorVertexList = new("dg.FactorVertexList"),
# factorEdgeList = new("dg.FactorEdgeList"),
visibleVertices = object@dg@visibleVertices,
visibleBlocks = numeric(),
extraList = object@dg@extraList,
extraEdgeList = object@dg@extraEdgeList)
} else if (viewType == "Essential") {
message("Essential view not implemented; ")
new("dg.graphedges",
viewType = viewType,
oriented = object@dg@oriented,
edgeList = object@dg@edgeList,
# blockEdgeList = new("dg.BlockEdgeList"),
# factorVertexList = new("dg.FactorVertexList"),
# factorEdgeList = new("dg.FactorEdgeList"),
visibleVertices = object@dg@visibleVertices,
visibleBlocks = numeric(),
extraList = object@dg@extraList,
extraEdgeList = object@dg@extraEdgeList)
} else if (viewType == "Simple") {
new("dg.graphedges",
viewType = viewType,
oriented = object@dg@oriented,
edgeList = object@dg@edgeList,
blockEdgeList = object@dg@blockEdgeList,
# factorVertexList = new("dg.FactorVertexList"),
# factorEdgeList = new("dg.FactorEdgeList"),
visibleVertices = object@dg@visibleVertices,
visibleBlocks = object@dg@visibleBlocks,
extraList = object@dg@extraList,
extraEdgeList = object@dg@extraEdgeList)
} else
message("View type not implemented; ")
})
setMethod("setGraphEdges", signature(object = "your.Model"),
function(object, dg = NULL, ...)
{
if (!is.null(dg)) object@dg <- dg
return(object)
})
setMethod("dg", signature(object = "your.Model"),
function(object,
modelObject = NULL,
modelObjectName = NULL,
control = dg.control(...),
...)
{
Names <- Your.function.for.extracting.variable.names.from.object(
object = object)
Types <- Your.function.for.extracting.variable.types.from.object(
object = object)
Edges <- Your.function.for.extracting.variable.edges.from.object(
object = object)
simpleGraph <- new("dg.simple.graph", vertex.names = Names,
types = Types, # edge.list = Edges,
from = Edges[,1], to = Edges[,2])
graph <- simpleGraphToGraph(simpleGraph)
dg(graph, object = object, ...)
})
setMethod("testEdge", signature(object = "your.Model"),
function(object, action, name.1, name.2, ...)
{
dots <- list(...)
from.type <- dots$from.type
to.type <- dots$to.type
f <- function(type) if(is.null(type)) "" else paste("(", type, ")")
message(paste("Should return an object with the edge from",
name.1, f(from.type), "to", name.2, f(to.type),
"deleted from the argument object"))
return(new("your.Test", name = "TestObject"))
})
setMethod("modifyModel", signature(object = "your.Model"),
function(object, action, name, name.1, name.2, ...)
{
dots <- list(...)
localArguments <- dots$Arguments
Edges <- dots$newEdges$vertexEdges
Vertices <- localArguments$vertexList
viewType <- "Simple"
DoFactors <- FALSE
if (!is.null(dots$Arguments)
&& !is.null(dots$Arguments$factorVertexList)
&& (length(dots$Arguments$factorVertexList) > 0)
&& !is.null(dots$Arguments$vertexList))
DoFactors <- TRUE
if (DoFactors)
viewType <- "Factor"
# print(names(dots))
# str(dots)
# print(names(localArguments))
# print(localArguments$visibleVertices)
# str(localArguments$selectedNodes)
# if (length(dots$selectedNodes) > 0)
# str(dots$selectedNodes)
# str(localArguments$selectedEdges)
# if (length(dots$selectedEdges) > 0)
# str(dots$selectedEdges)
FactorVertices <- new("dg.FactorVertexList")
FactorEdges <- new("dg.FactorEdgeList")
BlockEdges <- new("dg.BlockEdgeList")
VisibleVertices <- localArguments$visibleVertices
VisibleBlocks <- localArguments$visibleBlocks
ExtraVertices <- new("dg.VertexList")
ExtraEdges <- new("dg.ExtraEdgeList")
f <- function(type) if (is.null(type)) "" else paste("(", type, ")")
g <- function(type) if (is.null(type)) "" else type
if (action == "dropEdge") {
message(paste("Should return an object with the edge from",
name.1, f(dots$from.type), "to", name.2, f(dots$to.type),
"deleted from the argument object"))
if ((g(dots$from.type) == "Factor") || (g(dots$from.type) == "Factor"))
return(NULL)
} else if (action == "addEdge") {
message(paste("Should return an object with the edge from",
name.1, f(dots$from.type), "to", name.2, f(dots$to.type),
"added to the argument object"))
if ((g(dots$from.type) == "Factor") || (g(dots$from.type) == "Factor"))
return(NULL)
} else if (action == "dropVertex") {
message(paste("Should return an object with the vertex",
name, f(dots$type),
"deleted from the argument object"))
if ((g(dots$type) == "Factor"))
return(NULL)
VisibleVertices <- VisibleVertices[VisibleVertices != dots$index]
if (DoFactors && (dots$index > 0)) {
x <- (localArguments$factorVertexList)
factors <- lapply(x, function(i) i@vertex.indices)
types <- lapply(x, function(i) class(i))
factors <- lapply(factors,
function(x) {
y <- x[x != dots$index]
if (length(y) > 0) return(y) else return(NULL) } )
if (!is.null(factors)) {
types <- types[unlist(lapply(factors, function(i) !is.null(i)))]
factors <- .removeNull(factors)
}
if (!is.null(factors)) {
subset <- function(x)
lapply(x, function(a)
any(unlist(lapply(x,
function(A)
all(!is.na(match(a, A))) &&
(length(a) < length(A))))))
s <- subset(factors)
types <- types[!unlist(s)]
factors <- factors[!unlist(s)]
if (!(is.null(factors))) {
result <- returnFactorVerticesAndEdges(
localArguments$vertexList, factors, types,
factorClasses = validFactorClasses())
FactorVertices <- result$FactorVertices
FactorEdges <- result$FactorEdges
}
} else {
DoFactors <- FALSE
FactorVertices <- new("dg.FactorVertexList")
FactorEdges <- new("dg.FactorEdgeList")
}
}
} else if (action == "addVertex") {
VisibleVertices <- c(VisibleVertices, dots$index)
message(paste("Should return an object with the vertex",
name, f(dots$type), dots$index,
"added to the argument object"))
if (DoFactors && (dots$index > 0)) {
x <- (localArguments$factorVertexList)
factors <- lapply(x, function(i) i@vertex.indices)
types <- lapply(x, function(i) class(i))
if (!is.null(factors))
factors <- .removeNull(factors)
if (is.null(factors)) {
factors <- list(dots$index)
types <- validFactorClasses()[1, 1]
} else {
n <- length(types)
factors <- append(factors, list(dots$index))
types <- append(types, types[n])
}
if (!(is.null(factors))) {
result <- returnFactorVerticesAndEdges(
localArguments$vertexList, factors, types,
factorClasses = validFactorClasses())
FactorVertices <- result$FactorVertices
FactorEdges <- result$FactorEdges
}
}
}
if (is.null(FactorVertices) && DoFactors && !is.null(Edges)) {
factors <- .cliquesFromEdges(Edges, Vertices, VisibleVertices)
if (is.null(factors) || (length(factors) == 0)) {
FactorVertices <- new("dg.FactorVertexList")
FactorEdges <- new("dg.FactorEdgeList")
} else {
result <- returnFactorVerticesAndEdges(Vertices, factors)
FactorVertices <- result$FactorVertices
FactorEdges <- result$FactorEdges
}
}
dg <- new("dg.graphedges",
edgeList = Edges,
viewType = viewType,
# oriented = oriented,
blockEdgeList = BlockEdges,
factorVertexList = FactorVertices,
factorEdgeList = FactorEdges,
visibleVertices = VisibleVertices,
visibleBlocks = VisibleBlocks,
extraList = ExtraVertices,
extraEdgeList = ExtraEdges)
".IsEmpty" <- function(x) {
if (is.null(x) || (length(x) == 0) ||
(length(x) == 1) && is.null(x[[1]]))
return(TRUE)
else
return(FALSE)
}
if (.IsEmpty(FactorEdges) && (viewType == "Factor")) {
object <- setGraphEdges(object, dg = dg)
graphContent <- graphEdges(object, viewType = viewType,
Arguments = localArguments)
dg <- graphContent
}
return(list(object = object, dg = dg))
})
setMethod("Str", "your.Model",
function(object, setRowLabels = FALSE, title = "", ...) {
message(object@name) })
new("your.Model", name = "YourModelObject")Please choose more modern alternatives, such as Google Chrome or Mozilla Firefox.