67 lines
2.9 KiB
R
67 lines
2.9 KiB
R
elim_order <- function(G, node_sizes) {
|
|
# BEST_FIRST_ELIM_ORDER Greedily search for an optimal elimination order.
|
|
# order <- best_first_elim_order(moral_graph, node_sizes)
|
|
# Find an order in which to eliminate nodes from the graph in such a way as to try and minimize the
|
|
# weight of the resulting triangulated graph. The weight of a graph is the sum of the weights of each
|
|
# of its cliques the weight of a clique is the product of the weights of each of its members the
|
|
# weight of a node is the number of values it can take on.
|
|
# Since this is an NP - hard problem, we use the following greedy heuristic:
|
|
# at each step, eliminate that node which will result in the addition of the least
|
|
# number of fill - in edges, breaking ties by choosing the node that induces the lighest clique.
|
|
# For details, see
|
|
# - Kjaerulff, "Triangulation of graphs - - algorithms giving small total state space",
|
|
# Univ. Aalborg tech report, 1990 (www.cs.auc.dk/!uk)
|
|
# - C. Huang and A. Darwiche, "Inference in Belief Networks: A procedural guide",
|
|
# Intl. J. Approx. Reasoning, 11, 1994
|
|
|
|
# Warning: This code is pretty old and could probably be made faster.
|
|
|
|
n <- length(G)
|
|
# if (nargin < 3, stage = { 1:n } end# no constraints) {
|
|
|
|
# For long DBNs, it may be useful to eliminate all the nodes in slice t before slice t + 1.
|
|
# This will ensure that the jtree has a repeating structure (at least away from both edges).
|
|
# This is why we have stages.
|
|
# See the discussion of splicing jtrees on p68 of
|
|
# Geoff Zweig's PhD thesis, Dept. Comp. Sci., UC Berkeley, 1998.
|
|
# This constraint can increase the clique size significantly.
|
|
|
|
MG <- G# copy the original graph
|
|
uneliminated <- ones(1, n)
|
|
order <- zeros(1, n)
|
|
# t <- 1 # Counts which time slice we are on
|
|
for (i in 1:n) {
|
|
U <- find(uneliminated)
|
|
# valid <- myintersect(U, stage{t})
|
|
valid <- U
|
|
# Choose the best node from the set of valid candidates
|
|
min_fill <- zeros(1, length(valid))
|
|
min_weight <- zeros(1, length(valid))
|
|
for (j in 1:length(valid)) {
|
|
k <- valid(j)
|
|
nbrs <- myintersect(neighbors(G, k), U)
|
|
l <- length(nbrs)
|
|
M <- MG[nbrs, nbrs]
|
|
min_fill[j] <- l^2 - sum(M)# num. added edges
|
|
min_weight[j] <- prod(node_sizes[k, nbrs])# weight of clique
|
|
}
|
|
lightest_nbrs <- find(min_weight == min(min_weight))
|
|
# break ties using min - fill heuristic
|
|
best_nbr_ndx <- argmin(min_fill[lightest_nbrs])
|
|
j <- lightest_nbrs[best_nbr_ndx] # we will eliminate the j'th element of valid
|
|
# j1s <- find(score1 == min(score1))
|
|
# j <- j1s(argmin(score2(j1s)))
|
|
k <- valid(j)
|
|
uneliminated[k] <- 0
|
|
order[i] <- k
|
|
ns <- myintersect(neighbors(G, k), U)
|
|
if (!is.null(ns)) {
|
|
G[ns, ns] <- 1
|
|
G <- setdiag(G, 0)
|
|
}
|
|
# if (!any(as.logical(uneliminated(stage{t})))# are we allowed to the next slice?) {
|
|
# t <- t + 1
|
|
# }
|
|
}
|
|
return(order)
|
|
}
|