Definitions

Bayesian networks (BNs) are defined by:

• a network structure, a directed acyclic graph \(\mathcal{G}\), in which each node \(v_i \in \mathbf{V}\) corresponds to a random variable \(X_i\);
• a global probability distribution \(\mathbf{X}\) (with parameters \(\Theta\)), which can be factorised into smaller local probability distributions according to the arcs present in the graph.

The main role of the network structure is to express the conditional independence relationships among the variables in the model through graphical separation, thus specifying the factorisation of the global distribution: \[\begin{align*} &\operatorname{P}(\mathbf{X}) = \prod_{i=1}^N \operatorname{P}(X_i \mid\Pi_{X_i})& &\text{where}& &\Pi_{X_i} = \{ \text{parents of $X_i$} \}. \end{align*}\] Each local distribution has its own parameter set \(\Theta_{X_i}\); and \(\bigcup \Theta_{X_i}\) is much smaller than \(\Theta\) because many parameter are fixed by the fact that the variables they belong to are independent.

So the first component is a directed acyclic graph like this:

And the implication is that:

\[\begin{equation*} \operatorname{P}(\mathrm{A}, \mathrm{S}, \mathrm{E}, \mathrm{O}, \mathrm{R}, \mathrm{T}) = \operatorname{P}(\mathrm{A}) \operatorname{P}(\mathrm{S}) \operatorname{P}(\mathrm{E} \mid\mathrm{A}, \mathrm{S}) \operatorname{P}(\mathrm{O} \mid\mathrm{E}) \operatorname{P}(\mathrm{R} \mid\mathrm{E}) \operatorname{P}(\mathrm{T} \mid\mathrm{O}, \mathrm{R}) \end{equation*}\]

The second component of a BN is the probability distribution \(\operatorname{P}(\mathbf{X})\). The choice should be such that the BN:

• can be learned efficiently from data;
• is flexible (it can encode a reasonable variety of phenomena);
• is easy to query to perform inference.

The three most common choices in the literature (by far), are:

• discrete BNs, in which \(\mathbf{X}\) and the \(X_i \mid\Pi_{X_i}\) are multinomial; and the \(\Theta_{X_i}\) are the conditional probabilities \[\begin{equation*} \pi_{ik \mid j}= \operatorname{P}(X_i = k \mid\Pi_{X_i}= j). \end{equation*}\]
• Gaussian BNs (GBNs), in which \(\mathbf{X}\) is multivariate normal and the \(X_i \mid\Pi_{X_i}\) are univariate normals defined by the linear regression model \[\begin{align*} &X_i = \mu_{X_i} + \Pi_{X_i}\boldsymbol{\beta}_{X_i} + \varepsilon_{X_i},& &\varepsilon_{X_i} \sim N(0, \sigma^2_{X_i})., \end{align*}\]
• Conditional linear Gaussian BNs (CLGBNs), in which \(\mathbf{X}\) is a mixture of multivariate normals and the \(X_i \mid\Pi_{X_i}\) are either multinomial, univariate normal or mixtures of normals.
  • Discrete \(X_i\) are only allowed to have discrete parents (denoted \(\Delta_{X_i}\)), are assumed to follow a multinomial distribution parameterised with conditional probability tables;
  • continuous \(X_i\) are allowed to have both discrete and continuous parents (denoted \(\Gamma_{X_i}\), \(\Delta_{X_i}\cup \Gamma_{X_i}= \Pi_{X_i}\)), and their local distributions are \[\begin{equation*} X_i \mid\Pi_{X_i}\sim N\left(\mu_{X_i, \delta_{X_i}} + \Gamma_{X_i}\boldsymbol{\beta}_{X_i, \delta_{X_i}}, \sigma^2_{X_i, \delta_{X_i}}\right) \end{equation*}\] which can be written as a mixture of linear regressions \[\begin{align*} &X_i = \mu_{X_i, \delta_{X_i}} + \Gamma_{X_i}\boldsymbol{\beta}_{X_i, \delta_{X_i}} + \varepsilon_{X_i, \delta_{X_i}},& &\varepsilon_{X_i, \delta_{X_i}} \sim N\left(0, \sigma^2_{X_i, \delta_{X_i}}\right), \end{align*}\] against the continuous parents with one component for each configuration \(\delta_{X_i}\) of the discrete parents. If \(X_i\) has no discrete parents, the mixture reverts to a single linear regression.

Learning

Model selection and estimation of BNs are collectively known as learning, and are usually performed as a two-step process:

1. structure learning, learning the network structure from the data;
2. parameter learning, learning the local distributions implied by the structure learned in the previous step.

This workflow is Bayesian; given a data set \(\mathcal{D}\) and if we denote the parameters of the global distribution as \(\mathbf{X}\) with \(\Theta\), we have

\[\begin{equation*} \underbrace{\operatorname{P}(\mathcal{M} \mid\mathcal{D}) = \operatorname{P}(\mathcal{G}, \Theta \mid\mathcal{D})}_{\text{learning}} = \underbrace{\operatorname{P}(\mathcal{G}\mid\mathcal{D})}_{\text{structure learning}} \cdot\; \underbrace{\operatorname{P}(\Theta \mid\mathcal{G}, \mathcal{D})}_{\text{parameter learning}} \end{equation*}\] and structure learning is done in practice as \[\begin{equation*} \operatorname{P}(\mathcal{G}\mid\mathcal{D}) \propto \operatorname{P}(\mathcal{G})\operatorname{P}(\mathcal{D}\mid\mathcal{G}) = \operatorname{P}(\mathcal{G})\int \operatorname{P}(\mathcal{D}\mid\mathcal{G}, \Theta) \operatorname{P}(\Theta \mid\mathcal{G}) \,d\Theta. \end{equation*}\] Combined with the fact that the local distribution \(\operatorname{P}(\mathcal{D}\mid\mathcal{G}, \Theta)\) decomposes into local distributions that depend only on \(X_i\) and its parents \(\Pi_{X_i}\) \[\begin{align*} \operatorname{P}(\mathcal{D}\mid\mathcal{G}) = \int \operatorname{P}(\mathcal{D}\mid\mathcal{G}, \Theta) \operatorname{P}(\Theta \mid\mathcal{G}) \,d\Theta = \prod_{i=1}^N \int \operatorname{P}(X_i \mid\Pi_{X_i}, \Theta_{X_i}) \operatorname{P}(\Theta_{X_i}\mid\Pi_{X_i}) \,d\Theta_{X_i}. \end{align*}\]

Once we have an estimate for \(\mathcal{G}\) from structure learning, we can identify the local distributions \(X_i \mid\Pi_{X_i}\) since we know the parents of each node; and we can estimate their parameter set \(\Theta_{X_i}\) independently from each other. Assuming \(\mathcal{G}\) is sparse, each \(X_i \mid\Pi_{X_i}\) involves only few variables and thus estimating its parameters is computationally simple.

Inference

Inference on BNs usually consists of conditional probability (CP) or maximum a posteriori (MAP) queries. The general idea of a CP query is:

1. we have some evidence, that is, we know the values of some variables and we fix the nodes accordingly; and
2. we want to look into the probability of some event involving (a subset of) the other variables conditional on the evidence we have.

Say we start from a discrete BN with the DAG used above.

Graphically a CP query looks like this:

On the other hand, the goal of a MAP query is to find the combination of values for (a subset of) the variables in the network that has the highest probability given some evidence. If the evidence is a partially-observed new individual, then performing a MAP query amounts to a classic prediction exercise.

This is more computationally challenging than it sounds because, as a task, it does not decompose along local distributions.

Learning the Structure

The first step in learning a BN is learning its structure, that is, the DAG \(\mathcal{G}\). We can do that using data (from the diff data frame) combined with prior knowledge; incorporating the latter reduces the space of the models we will have to explore and leads to more robust BNs. A straightforward way of doing that is to blacklist arcs that encode relationships we know not be possible/real (we do not want them in \(\mathcal{G}\), even if noisy data might suggest they are real); and to whitelist arcs that encode relationship we know to exist (we do want them in \(\mathcal{G}\), even if they are not apparent from the data).

A blacklist is just a matrix (or a data frame) with a from and a to columns that lists the arcs we do not want in the BN.

• We blacklist any arc pointing to dT, Treatment and Growth from the orthodontic variables.
• We blacklist the arc from dT to Treatment. This means that whether a patient is treated does not change over time.
• We blacklist the arc from Growth to dT and Treatment. This means that whether a patient is treated does not change over time, and it obviously does not change depending on the prognosis.

bl = tiers2blacklist(list("dT", "Treatment", "Growth",
       c("dANB", "dPPPM", "dIMPA", "dCoA", "dGoPg", "dCoGo")))
bl = rbind(bl, c("dT", "Treatment"), c("Treatment", "dT"))
bl

      from        to         
 [1,] "Treatment" "dT"       
 [2,] "Growth"    "dT"       
 [3,] "dANB"      "dT"       
 [4,] "dPPPM"     "dT"       
 [5,] "dIMPA"     "dT"       
 [6,] "dCoA"      "dT"       
 [7,] "dGoPg"     "dT"       
 [8,] "dCoGo"     "dT"       
 [9,] "Growth"    "Treatment"
[10,] "dANB"      "Treatment"
[11,] "dPPPM"     "Treatment"
[12,] "dIMPA"     "Treatment"
[13,] "dCoA"      "Treatment"
[14,] "dGoPg"     "Treatment"
[15,] "dCoGo"     "Treatment"
[16,] "dANB"      "Growth"   
[17,] "dPPPM"     "Growth"   
[18,] "dIMPA"     "Growth"   
[19,] "dCoA"      "Growth"   
[20,] "dGoPg"     "Growth"   
[21,] "dCoGo"     "Growth"   
[22,] "dT"        "Treatment"
[23,] "Treatment" "dT"       

A whitelist has the same structure as a blacklist.

• We whitelist the dependence structure dANB \(\rightarrow\) dIMPA \(\leftarrow\) dPPPM.
• We whitelist the arc from dT to Growth which allows the prognosis to change over time.

wl = matrix(c("dANB", "dIMPA",
              "dPPPM", "dIMPA",
              "dT", "Growth"),
        ncol = 2, byrow = TRUE, dimnames = list(NULL, c("from", "to")))
wl

     from    to      
[1,] "dANB"  "dIMPA" 
[2,] "dPPPM" "dIMPA" 
[3,] "dT"    "Growth"

A simple approach to learn \(\mathcal{G}\) would be to find the network structure with the best goodness-of-fit on the whole data. For instance, using hc() with the default score (BIC) and the whole diff data frame:

dag = hc(diff, whitelist = wl, blacklist = bl)
dag

  Bayesian network learned via Score-based methods

  model:
   [dT][Treatment][Growth|dT:Treatment][dANB|Growth:Treatment]
   [dCoA|dANB:dT:Treatment][dGoPg|dANB:dCoA:dT:Growth]
   [dCoGo|dANB:dCoA:dT:Growth][dPPPM|dCoGo][dIMPA|dANB:dPPPM:Treatment]
  nodes:                                 9 
  arcs:                                  19 
    undirected arcs:                     0 
    directed arcs:                       19 
  average markov blanket size:           5.33 
  average neighbourhood size:            4.22 
  average branching factor:              2.11 

  learning algorithm:                    Hill-Climbing 
  score:                                 BIC (Gauss.) 
  penalization coefficient:              2.481422 
  tests used in the learning procedure:  157 
  optimized:                             TRUE 

To check how hc() actually built the network, and how various arcs were (not) included in \(\mathcal{G}\), we can just run the command above again with debug = TRUE:

----------------------------------------------------------------
* starting from the following network:

  Random/Generated Bayesian network

  model:
   [dANB][dPPPM][dCoA][dGoPg][dCoGo][dT][Treatment][dIMPA|dANB:dPPPM]
   [Growth|dT]
  nodes:                                 9 
  arcs:                                  3 
    undirected arcs:                     0 
    directed arcs:                       3 
  average markov blanket size:           0.89 
  average neighbourhood size:            0.67 
  average branching factor:              0.33 

  generation algorithm:                  Empty 

* current score: -2938.765 
* whitelisted arcs are:
     from    to      
[1,] "dANB"  "dIMPA" 
[2,] "dPPPM" "dIMPA" 
[3,] "dT"    "Growth"
* blacklisted arcs are:
      from        to         
 [1,] "Treatment" "dT"       
 [2,] "Growth"    "dT"       
 [3,] "dANB"      "dT"       
 [4,] "dPPPM"     "dT"       
 [5,] "dIMPA"     "dT"       
 [6,] "dCoA"      "dT"       
 [7,] "dGoPg"     "dT"       
 [8,] "dCoGo"     "dT"       
 [9,] "Growth"    "Treatment"
[10,] "dANB"      "Treatment"
[11,] "dPPPM"     "Treatment"
[12,] "dIMPA"     "Treatment"
[13,] "dCoA"      "Treatment"
[14,] "dGoPg"     "Treatment"
[15,] "dCoGo"     "Treatment"
[16,] "dANB"      "Growth"   
[17,] "dPPPM"     "Growth"   
[18,] "dIMPA"     "Growth"   
[19,] "dCoA"      "Growth"   
[20,] "dGoPg"     "Growth"   
[21,] "dCoGo"     "Growth"   
[22,] "dT"        "Treatment"
[23,] "dIMPA"     "dANB"     
[24,] "dIMPA"     "dPPPM"    
* caching score delta for arc dANB -> dPPPM (-1.539098).
* caching score delta for arc dANB -> dIMPA (0.856161).
* caching score delta for arc dANB -> dCoA (8.901223).
* caching score delta for arc dANB -> dGoPg (-0.934598).
* caching score delta for arc dANB -> dCoGo (-2.120463).
* caching score delta for arc dPPPM -> dIMPA (-2.846313).
* caching score delta for arc dPPPM -> dCoA (4.291717).
* caching score delta for arc dPPPM -> dGoPg (1.305411).
* caching score delta for arc dPPPM -> dCoGo (9.452469).
* caching score delta for arc dIMPA -> dCoA (-2.435017).
* caching score delta for arc dIMPA -> dGoPg (-2.106127).
* caching score delta for arc dIMPA -> dCoGo (-2.486190).
* caching score delta for arc dCoA -> dIMPA (-1.192979).
* caching score delta for arc dCoA -> dGoPg (93.911397).
* caching score delta for arc dCoA -> dCoGo (68.650076).
* caching score delta for arc dGoPg -> dIMPA (-0.413628).
* caching score delta for arc dGoPg -> dCoGo (56.572414).
* caching score delta for arc dCoGo -> dIMPA (-1.167656).
* caching score delta for arc dT -> dANB (-1.527379).
* caching score delta for arc dT -> dPPPM (0.063080).
* caching score delta for arc dT -> dIMPA (-0.659672).
* caching score delta for arc dT -> dCoA (51.008025).
* caching score delta for arc dT -> dGoPg (76.176115).
* caching score delta for arc dT -> dCoGo (51.756230).
* caching score delta for arc dT -> Growth (1.912126).
* caching score delta for arc Growth -> dANB (9.490576).
* caching score delta for arc Growth -> dPPPM (-2.486674).
* caching score delta for arc Growth -> dIMPA (-0.332326).
* caching score delta for arc Growth -> dCoA (-2.437912).
* caching score delta for arc Growth -> dGoPg (0.391115).
* caching score delta for arc Growth -> dCoGo (2.469922).
* caching score delta for arc Treatment -> dANB (23.927293).
* caching score delta for arc Treatment -> dPPPM (-1.158971).
* caching score delta for arc Treatment -> dIMPA (1.593137).
* caching score delta for arc Treatment -> dCoA (28.348451).
* caching score delta for arc Treatment -> dGoPg (11.934805).
* caching score delta for arc Treatment -> dCoGo (11.530382).
* caching score delta for arc Treatment -> Growth (0.358153).
----------------------------------------------------------------
* trying to add one of 45 arcs.
  > trying to add dANB -> dPPPM.
    > delta between scores for nodes dANB dPPPM is -1.539098.
  > trying to add dANB -> dCoA.
    > delta between scores for nodes dANB dCoA is 8.901223.
    @ adding dANB -> dCoA.
  > trying to add dANB -> dGoPg.
    > delta between scores for nodes dANB dGoPg is -0.934598.
  > trying to add dANB -> dCoGo.
    > delta between scores for nodes dANB dCoGo is -2.120463.
  > trying to add dPPPM -> dANB.
...

As for plotting \(\mathcal{G}\), the key function is graphviz.plot() which provides a simple interface to the Rgraphviz package.

graphviz.plot(dag, shape = "ellipse", highlight = list(arcs = wl))

However, the quality of dag crucially depends on whether variables are normally distributed and on whether the relationships that link them are linear; from the exploratory analysis it is not clear that is the case for all of them. We also have no idea about which arcs represent strong relationships, meaning that they are resistant to perturbations of the data. We can address both issues using boot.strength() to:

1. resample the data using bootstrap;
2. learn a separate network from each bootstrap sample;
3. check how often each possible arc appears in the networks;
4. construct a consensus network with the arcs that appear more often.

str.diff = boot.strength(diff, R = 200, algorithm = "hc",
            algorithm.args = list(whitelist = wl, blacklist = bl))
head(str.diff)

  from    to strength direction
1 dANB dPPPM    0.585 0.3333333
2 dANB dIMPA    1.000 1.0000000
3 dANB  dCoA    0.780 0.6794872
4 dANB dGoPg    0.455 0.7802198
5 dANB dCoGo    0.600 0.8791667
6 dANB    dT    0.175 0.0000000

The return value of boot.strength() includes, for each pair of nodes, the strength of the arc that connects them (say, how often we observe dANB \(\rightarrow\) dPPPM or dPPPM \(\rightarrow\) dANB) and the strength of its direction (say, how often we observe dANB \(\rightarrow\) dPPPM when we observe an arc at all between dANB and dPPPM). boot.strength() also computes the threshold that will be used to decide whether an arc is strong enough to be included in the consensus network.

attr(str.diff, "threshold")

[1] 0.465

So, averaged.network() takes all the arcs with a strength of at least 0.465 and returns an averaged consensus network, unless a different threshold is specified.

avg.diff = averaged.network(str.diff)

Plotting avg.diff with Rgraphviz, we can incorporate the information we now have on the strength of the arcs by using strength.plot() instead of graphviz.plot(). strength.plot() takes the same arguments as graphviz.plot() plus a threshold and a set of cutpoints to determine how to format each arc depending on its strength.

strength.plot(avg.diff, str.diff, shape = "ellipse", highlight = list(arcs = wl))

How can we compare the averaged network (avg.diff) with the network we originally learned in from all the data (dag)? The most qualitative way is to plot the two networks side by side, with the nodes in the same positions, and highlight the arcs that appear in one network and not in the other, or that appear with different directions.

par(mfrow = c(1, 2))
graphviz.compare(avg.diff, dag, shape = "ellipse", main = c("averaged DAG", "single DAG"))

We can see that the arcs Treatment \(\rightarrow\) dIMPA, dANB \(\rightarrow\) dGoPg and dCoGo \(\rightarrow\) dPPPM appear only in the averaged network, and that dPPPM \(\rightarrow\) dANB appears only in the network we learned from all the data. We can assume that the former three arcs were hidden by the noisiness of the data combined with the small sample sizes and departures from normality. The programmatic equivalent of graphviz.compare() is simply called compare(): it can return the number of true positives (arcs that appear in both networks) and false positives/negatives (arcs that appear in only one of thew two networks),

compare(avg.diff, dag)

$tp
[1] 17

$fp
[1] 2

$fn
[1] 1

or the arcs themselves, with arcs = TRUE.

compare(avg.diff, dag, arcs = TRUE)

$tp
      from        to      
 [1,] "dANB"      "dIMPA" 
 [2,] "dANB"      "dCoA"  
 [3,] "dANB"      "dCoGo" 
 [4,] "dPPPM"     "dIMPA" 
 [5,] "dCoA"      "dGoPg" 
 [6,] "dCoA"      "dCoGo" 
 [7,] "dT"        "dCoA"  
 [8,] "dT"        "dGoPg" 
 [9,] "dT"        "dCoGo" 
[10,] "dT"        "Growth"
[11,] "Growth"    "dANB"  
[12,] "Growth"    "dGoPg" 
[13,] "Growth"    "dCoGo" 
[14,] "Treatment" "dANB"  
[15,] "Treatment" "dIMPA" 
[16,] "Treatment" "dCoA"  
[17,] "Treatment" "Growth"

$fp
     from    to     
[1,] "dCoGo" "dPPPM"
[2,] "dANB"  "dGoPg"

$fn
     from    to    
[1,] "dPPPM" "dANB"

But are all the arc directions well established, in light of the fact that the networks are learned with BIC which is score equivalent? Looking at the CPDAGs for dag and avg.diff (and taking whitelists and blacklists into account), we see that there are no undirected arcs. All arcs directions are uniquely identified.

undirected.arcs(cpdag(dag, wlbl = TRUE))

     from to

avg.diff$learning$whitelist = wl
avg.diff$learning$blacklist = bl
undirected.arcs(cpdag(avg.diff, wlbl = TRUE))

     from to

Finally we can combine the compare() and cpdag() to perform a principled comparison in which we say two arcs are different if they have been uniquely identified being different.

compare(cpdag(avg.diff, wlbl = TRUE), cpdag(dag, wlbl = TRUE))

$tp
[1] 17

$fp
[1] 2

$fn
[1] 1

It is also a good idea to look at the threshold with respect to the distribution of the arc strengths: the averaged network is fairly dense (18 arcs for 9 nodes) and it is difficult to read.

plot(str.diff)
abline(v = 0.75, col = "tomato", lty = 2, lwd = 2)
abline(v = 0.85, col = "steelblue", lty = 2, lwd = 2)

Hence it would be good to increase the threshold a bit and to drop a few more arcs. Looking at the plot above, two natural choices for a higher threshold are \(0.75\) (red dashed line) and \(0.85\) (blue dashed line) because of the gaps in the distribution of the arc strengths.

nrow(str.diff[str.diff$strength > attr(str.diff, "threshold") & 
              str.diff$direction > 0.5, ])

[1] 19

nrow(str.diff[str.diff$strength > 0.75 & str.diff$direction > 0.5, ])

[1] 15

nrow(str.diff[str.diff$strength > 0.85 & str.diff$direction > 0.5, ])

[1] 13

The simpler network we obtain by setting threshold = 0.85 in averaged.network() is shown below; it is certainly easier to reason with from a qualitative point of view.

avg.simpler = averaged.network(str.diff, threshold = 0.85)
strength.plot(avg.simpler, str.diff, shape = "ellipse", highlight = list(arcs = wl))

Learning the Parameters

Having learned the structure, we can now learn the parameters. Since we are working with continuous variables, we choose to model them with a GBN. Hence if we fit the parameters of the network using their maximum likelihood estimate we have that each local distribution is a classic linear regression.

fitted.simpler = bn.fit(avg.simpler, diff)
fitted.simpler

  Bayesian network parameters

  Parameters of node dANB (Gaussian distribution)

Conditional density: dANB | Growth + Treatment
Coefficients:
(Intercept)       Growth    Treatment  
  -1.560045     1.173979     1.855994  
Standard deviation of the residuals: 1.416369 

  Parameters of node dPPPM (Gaussian distribution)

Conditional density: dPPPM | dCoGo
Coefficients:
(Intercept)        dCoGo  
  0.1852132   -0.2317049  
Standard deviation of the residuals: 2.50641 

  Parameters of node dIMPA (Gaussian distribution)

Conditional density: dIMPA | dANB + dPPPM
Coefficients:
(Intercept)         dANB        dPPPM  
 -1.3826102    0.4074842   -0.5018133  
Standard deviation of the residuals: 4.896511 

  Parameters of node dCoA (Gaussian distribution)

Conditional density: dCoA | Treatment
Coefficients:
(Intercept)    Treatment  
   3.546753     5.288095  
Standard deviation of the residuals: 3.615473 

  Parameters of node dGoPg (Gaussian distribution)

Conditional density: dGoPg | dCoA + dT + Growth
Coefficients:
(Intercept)         dCoA           dT       Growth  
  0.2065969    0.7149868    0.8334606   -1.6747242  
Standard deviation of the residuals: 2.233405 

  Parameters of node dCoGo (Gaussian distribution)

Conditional density: dCoGo | dCoA + dT + Growth
Coefficients:
(Intercept)         dCoA           dT       Growth  
  1.5378012    0.5932982    0.5240202   -2.0302255  
Standard deviation of the residuals: 2.428629 

  Parameters of node dT (Gaussian distribution)

Conditional density: dT
Coefficients:
(Intercept)  
   4.706294  
Standard deviation of the residuals: 2.550427 

  Parameters of node Growth (Gaussian distribution)

Conditional density: Growth | dT
Coefficients:
(Intercept)           dT  
 0.48694013  -0.01728446  
Standard deviation of the residuals: 0.4924939 

  Parameters of node Treatment (Gaussian distribution)

Conditional density: Treatment
Coefficients:
(Intercept)  
  0.4615385  
Standard deviation of the residuals: 0.5002708 

We can easily confirm that is the case by comparing the models produced by bn.fit() and lm(), for instance dANB.

fitted.simpler$dANB

  Parameters of node dANB (Gaussian distribution)

Conditional density: dANB | Growth + Treatment
Coefficients:
(Intercept)       Growth    Treatment  
  -1.560045     1.173979     1.855994  
Standard deviation of the residuals: 1.416369 

summary(lm(dANB ~ Growth + Treatment, data = diff))

Call:
lm(formula = dANB ~ Growth + Treatment, data = diff)

Residuals:
    Min      1Q  Median      3Q     Max 
-3.5400 -0.8139 -0.0959  0.7861  5.2861 

Coefficients:
            Estimate Std. Error t value Pr(>|t|)    
(Intercept)  -1.5600     0.1812  -8.609 1.37e-14 ***
Growth        1.1740     0.2440   4.812 3.82e-06 ***
Treatment     1.8560     0.2403   7.724 1.96e-12 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 1.416 on 140 degrees of freedom
Multiple R-squared:  0.407, Adjusted R-squared:  0.3985 
F-statistic: 48.04 on 2 and 140 DF,  p-value: < 2.2e-16

Can we have problems with collinearity? In theory it is possible, but it is mostly not an issue in practice with network structures learning from data. The reason is that if two variables \(X_j\) and \(X_k\) are collinear, after adding (say) \(X_i \leftarrow X_j\) then \(X_i \leftarrow X_k\) will no longer significantly improve BIC because \(X_j\) and \(X_k\) provide (to some extent) the same information on \(X_i\).

library(MASS)

Attaching package: 'MASS'

The following object is masked _by_ '.GlobalEnv':

    survey

# a three-dimensional multivariate Gaussian.
mu = rep(0, 3)
R = matrix(c(1,   0.6, 0.5,
             0.6, 1,   0,
             0.5, 0,   1), 
      ncol = 3, dimnames = list(c("y", "x1", "x2"), c("y", "x1", "x2")))

# gradually increase the correlation between the explanatory variables.
for (rho in seq(from = 0, to = 0.85, by = 0.05)) {
  
  # update the correlation matrix and generate the data.
  R[2, 3] = R[3, 2] = rho
  data = as.data.frame(mvrnorm(10000, mu, R))
  # compare the linear models (full vs reduced).
  cat("rho:", sprintf("%.2f", rho), "difference in BIC:",
    - 2 * (BIC(lm(y ~ x1 + x2, data = data)) - BIC(lm(y ~ x1, data = data))), "\n")

}#FOR

rho: 0.00 difference in BIC: 9979.512 
rho: 0.05 difference in BIC: 8840.991 
rho: 0.10 difference in BIC: 7422.147 
rho: 0.15 difference in BIC: 6491.416 
rho: 0.20 difference in BIC: 5158.786 
rho: 0.25 difference in BIC: 4627.572 
rho: 0.30 difference in BIC: 3893.142 
rho: 0.35 difference in BIC: 3342.032 
rho: 0.40 difference in BIC: 2415.447 
rho: 0.45 difference in BIC: 2153.147 
rho: 0.50 difference in BIC: 1971.906 
rho: 0.55 difference in BIC: 1186.694 
rho: 0.60 difference in BIC: 952.2061 
rho: 0.65 difference in BIC: 593.0437 
rho: 0.70 difference in BIC: 414.4811 
rho: 0.75 difference in BIC: 129.0313 
rho: 0.80 difference in BIC: 7.202262 
rho: 0.85 difference in BIC: -11.92082 

If parameter estimates are problematic for any reason, we can replace them with a new set of estimates from a different approach.

fitted.new = fitted.simpler
fitted.new$dANB = list(coef = c(-1, 2, 2), sd = 1.5)
fitted.new$dANB

  Parameters of node dANB (Gaussian distribution)

Conditional density: dANB | Growth + Treatment
Coefficients:
(Intercept)       Growth    Treatment  
         -1            2            2  
Standard deviation of the residuals: 1.5 

fitted.new$dANB = penalized::penalized(diff$dANB, penalized = diff[, parents(avg.simpler, "dANB")],
                    lambda2 = 20, model = "linear", trace = FALSE) 
fitted.new$dANB

  Parameters of node dANB (Gaussian distribution)

Conditional density: dANB | Growth + Treatment
Coefficients:
(Intercept)       Growth    Treatment  
 -1.1175168    0.8037963    1.2224956  
Standard deviation of the residuals: 1.469436 

Predictive Accuracy

We can measure predictive accuracy of our chosen learning strategy in the usual way, with cross-validation. bnlearn provides the bn.cv() function for this task, which implements:

• k-fold cross-validation;
• cross-validation with user-specified folds;
• hold-out cross-validation

for:

• structure learning algorithms (the structure and the parameters are learned from data);
• parameter learning algorithms (the structure is provided by the user, the parameters are learned from the data).

The return value of bn.cv() is an object of class bn.kcv (or bn.kcv-list for multiple cross-validation runs, see ?"bn.kcv class") that contains:

• the row indexes for the observations used as the test set;
• a bn.fit object learned from the training data;
• the value of the loss function;
• fitted and predicted values for loss functions that require them.

First we check Growth, which encodes the evolution of malocclusion (0 meaning Bad and 1 meaning Good). We check it transforming it back into discrete variable and computing the prediction error.

xval = bn.cv(diff, bn = "hc", algorithm.args = list(blacklist = bl, whitelist = wl),
  loss = "cor-lw", loss.args = list(target = "Growth", n = 200), runs = 10)

err = numeric(10)

for (i in 1:10) {

  tt = table(unlist(sapply(xval[[i]], '[[', "observed")),
             unlist(sapply(xval[[i]], '[[', "predicted")) > 0.50)

  err[i] = (sum(tt) - sum(diag(tt))) / sum(tt)

}#FOR

summary(err)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
 0.2727  0.2745  0.2867  0.2909  0.3007  0.3287 

The other variables are continuous, so we can estimate their predictive correlation instead.

predcor = structure(numeric(6),
            names = c("dCoGo", "dGoPg", "dIMPA", "dCoA", "dPPPM", "dANB"))

for (var in names(predcor)) {

  xval = bn.cv(diff, bn = "hc", algorithm.args = list(blacklist = bl, whitelist = wl),
           loss = "cor-lw", loss.args = list(target = var, n = 200), runs = 10)

    predcor[var] = mean(sapply(xval, function(x) attr(x, "mean")))

}#FOR

round(predcor, digits = 3)

dCoGo dGoPg dIMPA  dCoA dPPPM  dANB 
0.850 0.905 0.224 0.924 0.415 0.646 

mean(predcor)

[1] 0.660777

In both cases we use the *-lw variants of the loss functions, which perform prediction using posterior expected values computed from all the other variables. The base loss functions (cor, mse, pred) predict the values of each node just from their parents, which is not meaningful when working on nodes with few or no parents.

Confirming with Expert Knowledge

The other way to confirm whether the BN makes sense is to treat it as a working model of the world and to see whether it expresses key facts about the world that were not used as prior knowledge during learning. (Otherwise we would just be getting back the information we put in the prior!) Some examples:

1. “An excessive growth of CoGo should induce a reduction in PPPM.”
   We test this hypothesis by generating samples for the BN stored in fitted.simpler for both dCoGo and dPPPM and assuming no treatment is taking place. As dCoGo increases (which indicates an increasingly rapid growth) dPPPM becomes increasingly negative (which indicates a reduction in the angle assuming the angle is originally positive.

sim = cpdist(fitted.simpler, nodes = c("dCoGo", "dPPPM"), n = 10^4,
        evidence = (Treatment < 0.5))
plot(sim, col = "grey")
abline(v = 0, col = 2, lty = 2, lwd = 2)
abline(h = 0, col = 2, lty = 2, lwd = 2)
abline(coef(lm(dPPPM ~ dCoGo, data = sim)), lwd = 2)

2. “A small growth of CoGo should induce an increase in PPPM.”
   From the figure above, a negative or null growth of CoGo (dCoGo \(\leqslant 0\)) corresponds to a positive growth in PPPM with probability \(\approx 0.60\). For a small growth of CoGo (dCoGo \(\in [0, 2]\)) unfortunately dPPPM \(\leqslant 0\) with probability \(\approx 0.50\) so the BN does not support this hypothesis.

nrow(sim[(sim$dCoGo <= 0) & (sim$dPPPM > 0), ]) / nrow(sim[(sim$dCoGo <= 0), ])

[1] 0.5684211

nrow(sim[(sim$dCoGo > 0) & (sim$dCoGo < 2) & (sim$dPPPM > 0), ]) / 
  nrow(sim[(sim$dCoGo) > 0 & (sim$dCoGo < 2),  ])

[1] 0.4808743

3. “If ANB decreases, IMPA decreases to compensate.”
   Testing by simulation as before, we are looking for negative values of dANB (which indicate a decrease assuming the angle is originally positive) associated with negative values of IMPA (same). From the figure below dANB is proportional to dIMPA, so a decrease in one suggests a decrease in the other; the mean trend (the black line) is negative for both at the same time.

sim = cpdist(fitted.simpler, nodes = c("dIMPA", "dANB"), n = 10^4, evidence = (Treatment < 0.5))
plot(sim, col = "grey")
abline(v = 0, col = 2, lty = 2, lwd = 2)
abline(h = 0, col = 2, lty = 2, lwd = 2)
abline(coef(lm(dIMPA ~ dANB, data = sim)), lwd = 2)

4. “If GoPg increases strongly, then both ANB and IMPA decrease.”
   If we simulate dGoPg, dANB and dIMPA from the Bayesian network assuming dGoPg \(> 5\) (i.e. GoPg is increasing) we estimate the probability that dANB \(> 0\) (i.e. ANB is increasing) at \(\approx 0.70\) and that dIMPA \(< 0\) at only \(\approx 0.58\).

sim = cpdist(fitted.simpler, nodes = c("dGoPg", "dANB", "dIMPA"), n = 10^4,
        evidence = (dGoPg > 5) & (Treatment < 0.5))
nrow(sim[(sim$dGoPg > 5) & (sim$dANB < 0), ]) / nrow(sim[(sim$dGoPg > 5), ])

[1] 0.7076322

nrow(sim[(sim$dGoPg > 5) & (sim$dIMPA < 0), ]) / nrow(sim[(sim$dGoPg > 5), ])

[1] 0.5850361

5. “Therapy attempts to stop the decrease of ANB. If we fix ANB is there any difference treated and untreated patients?”
   First, we can check the relationship between treatment and growth for patients that have dANB \(\approx 0\) without any intervention (i.e. using the BN we learned from the data).

sim = cpdist(fitted.simpler, nodes = c("Treatment", "Growth"), n = 5 * 10^4, evidence = abs(dANB) < 0.1)
tab = table(TREATMENT = sim$Treatment < 0.5, GOOD.GROWTH = sim$Growth > 0.5)
round(prop.table(tab, margin = 1), 2)

         GOOD.GROWTH
TREATMENT FALSE TRUE
    FALSE  0.65 0.35
    TRUE   0.48 0.52

The estimated \(\operatorname{P}(\)GOOD.GROWTH \(\,|\,\) TREATMENT\()\) is different for treated and untreated patients (\(\approx 0.65\) versus \(\approx 0.52\)).

If we simulate a formal intervention (a la Judea Pearl) and externally set dANB \(= 0\) (thus making it independent from its parents and removing the corresponding arcs), we have that GOOD.GROWTH has practically the same distribution for both treated and untreated patients and thus becomes independent from TREATMENT. This suggests that a favourable prognosis is indeed determined by preventing changes in ANB and that other components of the treatment (if any) then become irrelevant.

avg.mutilated = mutilated(avg.simpler, evidence = list(dANB = 0))
fitted.mutilated = bn.fit(avg.mutilated, diff)
fitted.mutilated$dANB = list(coef = c("(Intercept)" = 0), sd = 0)
sim = cpdist(fitted.mutilated, nodes = c("Treatment", "Growth"), n = 5 * 10^4,
        evidence = TRUE)
tab = table(TREATMENT = sim$Treatment < 0.5, GOOD.GROWTH = sim$Growth > 0.5)
round(prop.table(tab, margin = 1), 2)

         GOOD.GROWTH
TREATMENT FALSE TRUE
    FALSE  0.57 0.43
    TRUE   0.58 0.42

6. “Therapy attempts to stop the decrease of ANB. If we fix ANB is there any difference treated and untreated patients?”
   One way of assessing this is to check whether the angle between point A and point B (ANB) changes between treated and untreated patients while keeping GoPg fixed.

sim.GoPg = cpdist(fitted.simpler, nodes = c("Treatment", "dANB", "dGoPg"),
        evidence = abs(dGoPg) < 0.1)

Assuming GoPg does not change, the angle between point A and point B increases for treated patients (strongly negative values denote horizontal imbalance, so a positive rate of changes indicate a reduction in imbalance) and decreases for untreated patients (imbalance slowly worsens over time).

sim.GoPg$Treatment = c("UNTREATED", "TREATED")[as.numeric(sim.GoPg$Treatment > 0.5) + 1L]
mean(sim.GoPg[sim.GoPg$Treatment == "UNTREATED", "dANB"])

[1] -1.007113

mean(sim.GoPg[sim.GoPg$Treatment == "TREATED", "dANB"])

[1] 0.2988403

boxplot(dANB ~ Treatment, data = sim.GoPg)