R/min-fill.R

In jtrecenti/ea2:

fill <- function(D, X) {
  ne <- unique(as.character(unlist(dplyr::filter(D, V1 == X | V2 == X))))
  ne <- ne[ne != X]
  n_ne <- length(ne)
  subg <- dplyr::filter(D, V1 %in% ne, V2 %in% ne, V1 != X, V2 != X)
  n_ne * (n_ne - 1) / 2 - nrow(subg)
}

nnodes <- function(D) {
  unique(unlist(D))
}

domain_graph <- function(bn) {
  D <- as.data.frame(do.call(rbind, lapply(bn, function(x) {
    n <- names(x$cpt)[names(x$cpt) != 'factor']
    if (length(n) == 1) return(matrix(ncol = 2, nrow = 0))
    t(apply(combn(n, 2), 2, function(x) x[order(tidyr::extract_numeric(x))]))
  })), stringsAsFactors = FALSE)
  D <- dplyr::distinct(D)
}

min_fill <- function(bn) {
  D <- domain_graph(bn)
  L <- character(length(bn))
  for (i in seq_along(nnodes(D))) {
    G <- nnodes(D)
    if(length(G) == 0) break
    fi <- numeric(length(G))
    for (j in seq_along(G)) {
      fi[j] <- fill(D, G[j])
      if (fi[j] == 0) break
    }
    L[i] <- G[which.min(fi)]
    D <- dplyr::filter(D, V1 != L[i], V2 != L[i])
  }
  L[L == ''] <- names(bn)[!names(bn) %in% L]
  L
}