max/ourMELONS
1
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

Translated elim_order()

Browse source
This commit is contained in:
Waldir Leoncio 2022-12-22 14:17:31 +01:00
parent aff5b3de15
commit c69c0639ae
1 changed files with 61 additions and 65 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

126
R/elim_order.R
View file

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