R/var-elim.R

In jtrecenti/ea2:

inference <- function(bn, Q, E, rm.barren = TRUE, mf = TRUE) {
  # query e evidencia
  Q_var <- sapply(stringr::str_match_all(as.character(Q), '(X[0-9]+) ?=='),
                  function(x) x[, 2])
  dist <- FALSE
  if (is.list(Q_var)) {
    Q_var <- as.character(Q)
    dist <- TRUE
  }
  E_var <- sapply(stringr::str_match_all(as.character(E), '(X[0-9]+) ?=='),
                  function(x) x[, 2])
  # removendo barren nodes
  if (rm.barren) {
    bn <- remove_barren(bn, Q_var, E_var)
  }
  # lista de funcionais
  f <- lapply(bn, function(x) assign_val(x$cpt, E))
  # elim_order <- names(bn)

  # ordem de eliminacao
  elim_order <- if(mf) min_fill(bn) else order_bn(bn)
  elim_order <- elim_order[!elim_order %in% c(Q_var, E_var)]

  for (i in seq_along(elim_order)) {
    # pega todos os fatores que envolvem X[i]
    ids <- sapply(f, function(g) elim_order[i] %in% names(g))
    # combina os fatores selecionados e depois tira X_i
    if (any(sapply(f[ids], nrow) > 1e4)) return(NULL)
    f_new <- sum_out(product(f[ids]), elim_order[i])
    # tira os potenciais da lista total e adiciona o ptencial
    f[ids] <- NULL
    f[[length(f) + 1]] <- f_new
  }
  # combina tudo no final
  res <- product(f)
  if (dist) {
    res <- res[, c(Q_var, 'factor')]
    res$factor <- res$factor / sum(res$factor)
    return(res)
  }
  with(res, res[eval(Q), ][['factor']] / sum(res[['factor']]))
}