| dg.Model-class {dynamicGraph} | R Documentation |
An example class for the model object of dynamicGraph.
newDefaultModelObject(name)
name |
Text string with the name of the model object. |
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,
graphComponents and setGraphComponents.
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 drawModel
can be used to draw the new graph.
If a value different from NULL is returned from modifyModel then
redrawView and drawModel 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 graphComponents and setGraphComponents
are used to communicate the graph components between several views
of the same model in dynamicGraphMain.
The method graphComponents of the model object is for returning
the objects to draw in the view, depending on the viewType.
If NULL is returned for a component in the returned list
from graphComponents 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 setGraphComponents 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 newDefaultTestObject.
name:"character":
The name of the 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 the model object.
#
# - At "message", insert the relevant code for testing and modifying the model.
#
# - The slots visibleVertices, visibleBlocks, extraVertices, vertexEdges,
# blockEdges, factorVertices, factorEdges, and, extraEdges should be
# eliminated, and you should in "graphComponents" return relevant lists.
#
setClass("your.Model",
representation(name = "character",
visibleVertices = "numeric",
visibleBlocks = "numeric",
extraVertices = "dg.VertexList",
vertexEdges = "dg.VertexEdgeList",
blockEdges = "dg.BlockEdgeList",
factorVertices = "dg.FactorVertexList",
factorEdges = "dg.FactorEdgeList",
extraEdges = "dg.ExtraEdgeList"))
"newYourModelObject"<- function(name) {
result <- new("your.Model", name = name,
extraVertices = .emptyDgList("dg.VertexList"),
vertexEdges = .emptyDgList("dg.VertexEdgeList"),
blockEdges = .emptyDgList("dg.BlockEdgeList"),
factorVertices = .emptyDgList("dg.FactorVertexList"),
factorEdges = .emptyDgList("dg.FactorEdgeList"),
extraEdges = .emptyDgList("dg.ExtraEdgeList"))
return(result)
}
if (!isGeneric("graphComponents")) {
if (is.function("graphComponents"))
fun <- graphComponents
else
fun <- function(object, viewType = NULL, ...)
standardGeneric("graphComponents")
setGeneric("graphComponents", fun)
}
setMethod("graphComponents", "your.Model",
function(object, viewType = NULL, ...)
{ # print(viewType); print ("graphComponents")
args <- list(...)
Args <- args$Arguments
Edges <- object@vertexEdges
Vertices <- Args$vertexList
VisibleVertices <- object@visibleVertices
if (viewType == "Factor") {
factors <- .cliquesFromEdges(Edges, Vertices, VisibleVertices)
if (is.null(factors) || (length(factors) == 0)) {
FactorVertices <- .emptyDgList("dg.FactorVertexList")
FactorEdges <- .emptyDgList("dg.FactorEdgeList")
} else {
result <- returnFactorVerticesAndEdges(Vertices, factors)
FactorVertices <- result$FactorVertices
FactorEdges <- result$FactorEdges
}
list(vertexEdges = object@vertexEdges,
blockEdges = object@blockEdges,
factorVertices = FactorVertices,
factorEdges = FactorEdges,
visibleVertices = object@visibleVertices,
visibleBlocks = object@visibleBlocks,
extraVertices = object@extraVertices,
extraEdges = object@extraEdges)
} else if (viewType == "Moral") {
message("Moral view not implemented; ")
list(vertexEdges = object@vertexEdges,
blockEdges = .emptyDgList("dg.BlockEdgeList"),
factorVertices = .emptyDgList("dg.FactorVertexList"),
factorEdges = .emptyDgList("dg.FactorEdgeList"),
visibleVertices = object@visibleVertices,
visibleBlocks = numeric(),
extraVertices = object@extraVertices,
extraEdges = object@extraEdges)
} else if (viewType == "Essential") {
message("Essential view not implemented; ")
list(vertexEdges = object@vertexEdges,
blockEdges = .emptyDgList("dg.BlockEdgeList"),
factorVertices = .emptyDgList("dg.FactorVertexList"),
factorEdges = .emptyDgList("dg.FactorEdgeList"),
visibleVertices = object@visibleVertices,
visibleBlocks = numeric(),
extraVertices = object@extraVertices,
extraEdges = object@extraEdges)
} else if (viewType == "Simple") {
list(vertexEdges = object@vertexEdges,
blockEdges = object@blockEdges,
factorVertices = .emptyDgList("dg.FactorVertexList"),
factorEdges = .emptyDgList("dg.FactorEdgeList"),
visibleVertices = object@visibleVertices,
visibleBlocks = object@visibleBlocks,
extraVertices = object@extraVertices,
extraEdges = object@extraEdges)
} else
message("View type not implemented; ")
})
if (!isGeneric("setGraphComponents")) {
if (is.function("setGraphComponents"))
fun <- setGraphComponents
else
fun <- function(object, viewType = NULL,
visibleVertices = NULL,
extraVertices = NULL,
vertexEdges = NULL,
blockEdges = NULL,
factorVertices = NULL,
factorEdges = NULL,
extraEdges = NULL, ...)
standardGeneric("setGraphComponents")
setGeneric("setGraphComponents", fun)
}
setMethod("setGraphComponents", signature(object = "your.Model"),
function(object, viewType = NULL,
visibleVertices = NULL,
visibleBlocks = NULL,
extraVertices = NULL,
vertexEdges = NULL,
blockEdges = NULL,
factorVertices = NULL,
factorEdges = NULL,
extraEdges = NULL, ...)
{
if (!is.null(visibleVertices)) object@visibleVertices <- visibleVertices
if (!(viewType == "Moral"))
if (!is.null(visibleBlocks )) object@visibleBlocks <- visibleBlocks
if (!is.null(extraVertices )) object@extraVertices <- extraVertices
if (!is.null(vertexEdges )) object@vertexEdges <- vertexEdges
if (!is.null(blockEdges )) object@blockEdges <- blockEdges
if ((viewType == "Factor")) {
if (!is.null(factorVertices )) object@factorVertices <- factorVertices
if (!is.null(factorEdges )) object@factorEdges <- factorEdges
}
return(object)
})
if (!isGeneric("dynamic.Graph")) {
if (is.function("dynamic.Graph"))
fun <- dynamic.Graph
else
fun <- function(object, ...)
standardGeneric("dynamic.Graph")
setGeneric("dynamic.Graph", fun)
}
setMethod("dynamic.Graph", signature(object = "your.Model"),
function(object, ...)
{
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)
DynamicGraph(names = Names, types = Types,
from = Edges[,1], to = Edges[,2],
object = object, ...)
})
if (!isGeneric("testEdge")) {
if (is.function("testEdge"))
fun <- testEdge
else
fun <- function(object, action, name.1, name.2, ...)
standardGeneric("testEdge")
setGeneric("testEdge", fun)
}
setMethod("testEdge", signature(object = "your.Model"),
function(object, action, name.1, name.2, ...)
{
args <- list(...)
from.type <- args$from.type
to.type <- args$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(newYourTestObject())
})
if (!isGeneric("modifyModel")) {
if (is.function("modifyModel"))
fun <- modifyModel
else
fun <- function(object, action, name, name.1, name.2, ...)
standardGeneric("modifyModel")
setGeneric("modifyModel", fun)
}
setMethod("modifyModel", signature(object = "your.Model"),
function(object, action, name, name.1, name.2, ...)
{
args <- list(...)
Args <- args$Arguments
Edges <- args$newEdges$vertexEdges
Vertices <- Args$vertexList
DoFactors <- FALSE
if (!is.null(args$Arguments)
&& !is.null(args$Arguments$factorVertexList)
&& (length(args$Arguments$factorVertexList) > 0)
&& !is.null(args$Arguments$vertexList))
DoFactors <- TRUE
FactorVertices <- NULL
FactorEdges <- NULL
BlockEdges <- NULL
VisibleVertices <- Args$visibleVertices
VisibleBlocks <- Args$visibleBlocks
ExtraVertices <- NULL
ExtraEdges <- NULL
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(args$from.type), "to", name.2, f(args$to.type),
"deleted from the argument object"))
if ((g(args$from.type) == "Factor") || (g(args$from.type) == "Factor"))
return(NULL)
} else if (action == "addEdge") {
message(paste("Should return an object with the edge from",
name.1, f(args$from.type), "to", name.2, f(args$to.type),
"added to the argument object"))
if ((g(args$from.type) == "Factor") || (g(args$from.type) == "Factor"))
return(NULL)
} else if (action == "dropVertex") {
message(paste("Should return an object with the vertex",
name, f(args$type),
"deleted from the argument object"))
if ((g(args$type) == "Factor"))
return(NULL)
VisibleVertices <- VisibleVertices[VisibleVertices != args$index]
if (DoFactors && (args$index > 0)) {
x <- (args$Arguments$factorVertexList)
factors <- lapply(x, function(i) i@vertex.indices)
types <- lapply(x, function(i) class(i))
factors <- lapply(factors,
function(x) {
y <- x[x != args$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(
args$Arguments$vertexList, factors, types,
factorClasses = validFactorClasses())
FactorVertices <- result$FactorVertices
FactorEdges <- result$FactorEdges
}
} else {
DoFactors <- FALSE
FactorVertices <- .emptyDgList("dg.FactorVertexList")
FactorEdges <- .emptyDgList("dg.FactorEdgeList")
}
}
} else if (action == "addVertex") {
VisibleVertices <- c(VisibleVertices, args$index)
message(paste("Should return an object with the vertex",
name, f(args$type), args$index,
"added to the argument object"))
if (DoFactors && (args$index > 0)) {
x <- (args$Arguments$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(args$index)
types <- validFactorClasses()[1, 1]
} else {
n <- length(types)
factors <- append(factors, list(args$index))
types <- append(types, types[n])
}
if (!(is.null(factors))) {
result <- returnFactorVerticesAndEdges(
args$Arguments$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 <- .emptyDgList("dg.FactorVertexList")
FactorEdges <- .emptyDgList("dg.FactorEdgeList")
} else {
result <- returnFactorVerticesAndEdges(Vertices, factors)
FactorVertices <- result$FactorVertices
FactorEdges <- result$FactorEdges } }
return(list(object = object,
BlockEdges = BlockEdges,
FactorVertices = FactorVertices,
FactorEdges = FactorEdges,
VisibleVertices = VisibleVertices,
VisibleBlocks = VisibleBlocks,
ExtraVertices = ExtraVertices,
ExtraEdges = ExtraEdges))
})
setMethod("Str", "your.Model",
function(object, setRowLabels = FALSE, title = "", ...) {
message(object@name) })
newYourModelObject("ModelObject")