2

我尝试从 R 的库中修改类bn.fit( ) 的对象。我需要bn.fit.dnetbnlearn

  1. 为 bn.fit$node$prob 表中的每一行设置相等的概率。为此，我使用下一个代码： 
    library(bnlearn)
library(purrr)

data(insurance)

bn <- tabu(insurance, score = "bic")
bn_fit <- bn.fit(bn, insurance, method = 'bayes')

bn_fit[1:length(bn_fit)] <- modify(bn_fit[1:length(bn_fit)], function(node) {
  node$prob <- modify(node$prob, ~(1 / NROW(node$prob)))
  node
})

我认为这种方法有点难看，几乎可以肯定存在更优雅的方法来做到这一点。我无法删除1:length(bn_fit)。另外我不知道为什么我不能在我的代码中NROW(.x)使用。NROW(node$prob)

  1. 在bn.fit$node$prob表中的每一列上设置任意分布。在这种情况下，我不明白如何避免 for 循环。

相关问题在这里

4

1 回答 1

1

关于 (1)，modify取 alist或 a atomic vector。bn_fit是类的bn.fit, bn.fit.dnet，但是，在引擎盖下它也是类list，因为调用typeof()yield list。我的猜测是没有用于子集这些类的 S3 通用方法，因此 R 发现它本质上是 alist并因此剥离了类参数。所以 subsettingbn_fit把它变成class list，因此你可以使用modify它。子集甚至可以用空括号来完成[]，它只会返回对象，但这次是class list. 我在下面使用的另一种方法是“手动”将class属性设置为NULLvia attr(bnfit, "class") <- NULL。

关于（2），我编写了一个tidyverse基于函数，可用于将prob每个节点的表更改为bayesm::rdirichlet分布（参见下面的代码）。用户仍然需要提供部分alpha参数（长度参数由每个 prob 的长度给出table）。在引擎盖下，该功能依赖于purrr::modify. 它通过首先剥离它们并在修改完成后将它们添加回来来处理这些类。我的方法是将 prob tables 转换为sdata.frame然后修改Freq列并针对现有的其他变量（组）进行调整，然后通过.data.frametablextabsreformulate

我对贝叶斯网络不是很深入，所以我不知道这个函数可以推广到什么程度，或者它是否只适用于你提供的数据集。此外，请测试修改后的对象是否被期望 class 的函数接受bn.fit, bn.fit.dnet。

我试图评论我的代码的每一步，但请询问是否有不清楚的地方。

（3）关于您的问题，为什么NROW(.x)在您的代码中不起作用并且您必须使用 NROW(node$prob) 代替：这与modify在 prob 上循环的方式有关table。检查循环的元素的一个好方法modify是使用purrr::pluck.

library(bnlearn)
library(tidyverse)

data(insurance)

bn <- tabu(insurance, score = "bic")
bn_fit <- bn.fit(bn, insurance, method = 'bayes')

change_bn_prob_table <- function(bnfit, alpha) {
  
  # save class attribute of bnfit object
  old_class <- attr(bnfit, "class")
  
  # strip class so that `modify` can be used
  attr(bnfit, "class") <- NULL
  
  # loop over `prop` tables of each node
  new <- purrr::modify(bnfit, function(x) {
    
    # save attributes of x 
    old_x_attr <- attributes(x)
    
    # save attributes of x[["prob"]]
    old_xprob_attr <- attributes(x[["prob"]])
    
    # turn `table` into data.frame
    inp <- as.data.frame(x[["prob"]]) 
    # save names apart from `Freq`
    cnames <- inp %>% select(-Freq) %>% colnames
    
    out <- inp %>% 
      # overwrite column `Freq` with probabilities from bayesm::rdirichlet
      # alpha needs to be supplied (the length of alpha is given by `nrow`)
      mutate(Freq := bayesm::rdirichlet(c(rep(alpha, nrow(inp))))) %>% 
      # devide probilities by sum of Freq in all remaining groups
      group_by(!!! syms(cnames[-1])) %>% 
      mutate(Freq := Freq/sum(Freq)) %>% 
      # turn data.frame back into prob table using formula notation via reformulate
      xtabs(reformulate(paste(colnames(.)), "Freq"), .)
    
    # strip `call` attribute from newly generated prob table
    attr(out, "call") <- NULL  
    # add `class` `table` as attribute
    attr(out, "class") <- "table"
    
    # restore old attribues and write x out to x$prob
    attributes(out) <- old_xprob_attr
    x[["prob"]] <- out
    
    # restore old attribues and return x
    attributes(x) <- old_x_attr
    x
    
  })
  
  # add saved class attributes 
  attr(new, "class") <- old_class
  new
  
}
# here `2` is the first part of `alpha` of `bayesm::rdirichlet`
bn_fit2 <- change_bn_prob_table(bn_fit, 2)

# test that `logLik` can be used on new modified bnfit object 
logLik(bn_fit2, insurance)
#> [1] -717691.8

由reprex 包（v0.3.0）于 2020-06-21 创建

于 2020-06-19T23:56:30.617 回答