---
title: "Captain_Example"
author: "Claude Boivin^[Retired Statistician, Stat.ASSQ]"
date: "2018-06-20. Revised 2020-02-09"
output: rmarkdown::html_vignette
# output: word_document
vignette: >
%\VignetteIndexEntry{Captain_Example}
%\VignetteEngine{knitr::rmarkdown}
%\VignetteEncoding{UTF-8}
---
```{r setup, include=FALSE}
# devtools::load_all(".") # only used in place of dst when testing with R-devel
library(dst)
#
knitr::opts_knit$set(echo = TRUE, root.dir = "..")
```
# Summary
The Captain’s Problem has been introduced by R. G. Almond ^[Almond, R. G. (1989). Fusion and Propagation in Graphical Belief Models: An Implementation and an Example. Ph.D. dissertation and Harvard University, Department of Statistics Technical Report S-130, pp 210-214.] as an example to illustrate how to specify a graphical belief model and how to combine the belief functions with an algorithm called Fusion and Propagation. Lately, P. P. Shenoy has revisited this example in great detail in a presentation on Valuation-Based Systems ^[P. P. Shenoy. Valuation-Based Systems. Third School on Belief Functions and Their Applications, Stella Plage, France. September 30, 2015.].
# The Captain’s Problem
The goal is to find the Arrival delay of the ship, a number of days varying from 0 to 6. This delay is the sum of two kinds of delay, the Departure delay and the Sailing delay. The Departure delay is the sum of three kind of delays, Loading, Maintenance and Forecast of bad weather. In this example, each delay is supposed to be of only one day for a maximum of three days. The Sailing delay can occur from bad Weather (one day) or Repairs at sea (one day each).
There are 8 variables involved: (Arrival delay, Departure delay, Sailing delay, Loading delay, Forecast of the weather, Maintenance delay, Weather at sea, Repairs at sea).
Six relations (R1 to R6) are defined between these variables.
Finally three inputs of evidence (L, F, M) are given.
## Relations between the variables:
### R1: ADS
A = D + S.
$Ω_A$ = {0,1,2,3,4,5,6}; $Ω_D$ = {0,1,2,3}; $Ω_S$ = {0,1,2,3}
```{r Relation ADS}
# library(dst)
ads
ads_tt<- ads[-1,-c(1,2)]
ads_tt <- as.matrix(ads_tt)
ads_info = matrix(c(1,2,3,7,4,4), ncol = 2, dimnames = list(NULL, c("varnb", "size")) )
ads_spec = matrix(c(rep(1,16), 2,rep(1,16),0), ncol = 2, dimnames = list(NULL, c("specnb", "mass")))
ads_rel <- bcaRel(tt = ads_tt, spec = ads_spec, infovar = ads_info, varnames = c("Arrival", "Departure", "Sail"), relnb = 1)
bcaPrint(ads_rel)
```
### R2: DLFM
D =sum of delays of 1 day for each delay of L (L = true), F (F = foul) or M (M = true).
$Ω_D$ = {0,1,2,3}; $Ω_L$ = {true, false}; $Ω_F$ = {foul, fair}; $Ω_M$ = {true, false}.
```{r Relation DLFM}
dlfm
dlfm_tt<- dlfm[-1,-c(1,2)]
dlfm_tt <- as.matrix(dlfm_tt)
colnames(dlfm_tt) <- colnames(dlfm)[-c(1,2)]
dlfm_info = matrix(c(2,4,5,6,4,2,2,2), ncol = 2, dimnames = list(NULL, c("varnb", "size")) )
dlfm_spec = matrix(c(rep(1,8), 2,rep(1,8),0), ncol = 2, dimnames = list(NULL, c("specnb", "mass")))
dlfm_rel <- bcaRel(tt = dlfm_tt, spec = dlfm_spec, infovar = dlfm_info, varnames = c("Departure", "Loading", "Forecast", "Maintenance"), relnb = 2)
bcaPrint(dlfm_rel)
```
### R3: SWR
R3 : S = sum of delays of 1 day for each condition in W (W = foul) or R (R = true) or both, true 90 % of the time. $Ω_S$ = {0,1,2,3}; $Ω_W$= {foul, fair}; $Ω_R$ = {true, false}.
m({0 fair false}, {1 foul false}, {1 fair true}, {2 foul true}) = 0.9;
m($Ω_S$ x $Ω_W$ x $Ω_R$) = 0.1.
```{r Relation SWR}
swr
swr_tt<- swr[-1,-c(1,2)]
swr_tt <- as.matrix(swr_tt)
swr_info = matrix(c(3,7,8,4,2,2), ncol = 2, dimnames = list(NULL, c("varnb", "size")) )
swr_spec = matrix(c(rep(1,4), 2,rep(0.9,4), 0.1), ncol = 2, dimnames = list(NULL, c("specnb", "mass")))
swr_rel <- bcaRel(tt = swr_tt, spec = swr_spec, infovar = swr_info, varnames = c("Sail", "Weather", "Repairs"), relnb = 3)
bcaPrint(swr_rel)
```
### R4: FW
$Ω_F$ = {foul, fair}; $Ω_W$= {foul, fair}.
W $\leftrightarrow$ F in (W x F):
m({foul, foul), (fair, fair)} = 0.8 ;
m($Ω_W$ x $Ω_F$) = 0.2
```{r Relation FW}
fw
fw_tt<- fw[-1,-c(1,2)]
fw_tt <- as.matrix(fw_tt)
fw_info = matrix(c(5,7,2,2), ncol = 2, dimnames = list(NULL, c("varnb", "size")) )
fw_spec = matrix(c(rep(1,2), 2,rep(0.8,2), 0.2), ncol = 2, dimnames = list(NULL, c("specnb", "mass")))
fw_rel <- bcaRel(tt = fw_tt, spec = fw_spec, infovar = fw_info, varnames = c("Forecast", "Weather"), relnb = 4)
bcaPrint(fw_rel)
```
### R5: MR
$Ω_M$ = {true, false}; $Ω_R$ = {true, false}.
We specify R if M = true in (M x R). This is done in two parts.
Specification 1. (M = true) $\rightarrow$ (R = true) with mass = 0.1
m({(true, true), (false, true), (false, false)}) = 0.1.
Specification 2. (M = true) $\rightarrow$ (R = false) with mass = 0.7
m({(false, true), (true, false), (false, false)}) = 0.7
m($Ω_M$ x $Ω_R$) = 0.2
```{r Relation MR1}
mrt
mrt_tt<- mrt[-1,-c(1,2)]
mrt_tt <- as.matrix(mrt_tt)
colnames(mrt_tt) <- c("true", "false", "true", "false")
mrt_info = matrix(c(6,8,2,2), ncol = 2, dimnames = list(NULL, c("varnb", "size")) )
mrt_spec = matrix(c(rep(1,3), rep(2,3), 3, rep(0.1,3), rep(0.7,3), 0.2), ncol = 2, dimnames = list(NULL, c("specnb", "mass")))
mrt_rel <- bcaRel(tt = mrt_tt, spec = mrt_spec, infovar = mrt_info, varnames = c("Maintenance", "Repairs"), relnb = 5)
bcaPrint(mrt_rel)
```
### R6: MR
$Ω_M$ = {true, false}; $Ω_R$ = {true, false}.
We specify R if M = false in (M x R). This is done in two parts.
Specification 1. (M = false) $\rightarrow$ (R = true) with mass = 0.2
m({(true, false), (true, true), (false, true)}) = 0.2,
Specification 2. (M = false) $\rightarrow$ (R = false) with mass = 0.2
m({(false, false), (true, true), (true, false)}) = 0.2
m($Ω_M$ x $Ω_R$) = 0.6
```{r Relation MR2}
mrf
mrf_tt<- mrf[-1,-c(1,2)]
mrf_tt <- as.matrix(mrf_tt)
mrf_info = matrix(c(6,8,2,2), ncol = 2, dimnames = list(NULL, c("varnb", "size")) )
mrf_spec = matrix(c(rep(1,3), rep(2,3), 3, rep(0.2,3), rep(0.2,3), 0.6), ncol = 2, dimnames = list(NULL, c("specnb", "mass")))
mrf_rel <- bcaRel(tt = mrf_tt, spec = mrf_spec, infovar = mrf_info, varnames = c("Maintenance", "Repairs"), relnb = 6)
bcaPrint(mrf_rel)
```
### Combination of R5 and R6: new R5
Since R5 and R6 are defined on the same space MxR, we can immediately combine them in a single relation, using Dempster Rule of combination.
```{r Relation MR12}
mr_rel <- nzdsr(dsrwon(mrt_rel, mrf_rel))
bcaPrint(mr_rel)
```
## Input of evidence
### 1: Loading delay
$Ω_L$ = {true, false}.
m({true}) = 0.5 ; m({false})= 0.3 ; m({true}, {false}) = 0.2
```{r evidence Loading}
l_rel <- bca(tt = matrix(c(1,0,0,1,1,1), ncol = 2, byrow = TRUE), m = c(0.3, 0.5, 0.2), cnames = c("true", "false"), idvar = 4, varnames = "Loading")
bcaPrint(l_rel)
```
### Evidence 2: Forecast of Weather
$Ω_W$= {foul, fair}.
m({foul}) = 0.2 ; m({fair})= 0.6 ; m({foul}, {fair}) = 0.2
```{r evidence Forecast}
f_rel <- bca(tt = matrix(c(1,0,0,1,1,1), ncol = 2, byrow = TRUE), m = c(0.2, 0.6, 0.2), cnames = c("foul", "fair"), idvar = 5, varnames = "Forecast")
bcaPrint(f_rel)
```
### Evidence 3: Maintenance before sailing
$Ω_M$ = {true, false},
m({true}) = 0 ; m({false})= 1 .
```{r evidence Maintenance}
m_rel <- bca(tt = matrix(c(1,0,0,1), ncol = 2, byrow = TRUE), m = c(0, 1), cnames = c("true", "false"), idvar = 6, varnames = "Maintenance")
bcaPrint(m_rel)
```
## The hypergraph of the Captain’s Problem
We now look at the Captain’s Problem as a belief network.
The eight variables involved are the nodes of the graph: Arrival, Departure, Sailing, Loading, Forecast, Maintenance, Weather, Repairs. The edges (hyperedges) are given by the five relations R1 to R5 and the three inputs of evidence (L, F, M).
We use the package igraph ^[Csardi G, Nepusz T: The igraph software package for complex network research, InterJournal, Complex Systems 1695. 2006. https://igraph.org] to produce a bipartite graph corresponding to the desired hypergraph.
```{r, fig.show='hold', fig_caption: yes}
# The network
if (requireNamespace("igraph", quietly = TRUE) ) {
library(igraph)
# Encode pieces of evidence and relations with an incidence matrix
R1 <- 1*1:8 %in% ads_rel$infovar[,1]
R2 <- 1*1:8 %in% dlfm_rel$infovar[,1]
R3 <- 1*1:8 %in% swr_rel$infovar[,1]
R4 <- 1*1:8 %in% fw_rel$infovar[,1]
R5 <- 1*1:8 %in% mr_rel$infovar[,1]
E1 <- 1*1:8 %in% l_rel$infovar[,1]
E2 <- 1*1:8 %in% f_rel$infovar[,1]
E3 <- 1*1:8 %in% m_rel$infovar[,1]
# information on variables
captain_vars1 <- c( ads_rel$valuenames, dlfm_rel$valuenames[2:4], swr_rel$valuenames[2:3])
captain_vars <- rbind( ads_rel$infovar, dlfm_rel$infovar[2:4,], swr_rel$infovar[2:3,])
captain_var_names <-names(captain_vars1)
rownames(captain_vars) <- captain_var_names
# infos on relations
captain_rel_names <- c("ads_rel", "dlfm_rel", "swr_rel", "fw_rel", "mr_rel", "l_rel", "f_rel", "m_rel")
# the incidence matrix
captain_hgm <- matrix(c(R1,R2,R3,R4,R5,E1,E2,E3), ncol=8, dimnames = list(c("Arrival", "Departure", "Sailing", "Loading", "Forecast", "Maintenance", "Weather", "Repairs"), c("R1", "R2", "R3", "R4","R5","E1","E2","E3")))
captain <- list(captain_hgm, captain_var_names, captain_rel_names)
#
## The graph structure of the problem
#
captain_hg <- graph_from_biadjacency_matrix(incidence = captain_hgm, directed = FALSE, multiple = FALSE, weighted = NULL,add.names = NULL)
V(captain_hg)
# Show variables as circles, relations and evidence as rectangles
V(captain_hg)$shape <- c("circle", "crectangle")[V(captain_hg)$type+1]
V(captain_hg)$label.cex <- 0.6
V(captain_hg)$label.font <- 2
# render graph
plot(captain_hg, vertex.label = V(captain_hg)$name, vertex.size=(3+6*V(captain_hg)$type)*6)
}
```
## Calculations to obtain the belief function of the Arrival delay using the peeling algorithm
Our goal is the calculation of the belief function of the variable of interest "Arrival". We apply an algorithm called "Peeling" to the belief network. This is a process of successive elimination of variables (peeling) until only the variable of interest (*Arrival* here) remains. The elimination of a variable has the effect of integrating its contribution to the reduced graph, which is also called "message passing".
Four parameters are necessary to trigger the algorithm. The first three are already defined when constructing the hypergraph. These are:
captain_vars1: Variable numbers and size
captain_rel_names: names of relations and evidences
captain_hgm: Incidence matrix of the hypergraph
The fourth parameter is an order of elimination of the variables that we have to set. here we set the elimination order to:
8 Repairs
4 Loading
7 Weather
2 Departure
6 Maintenance
5 Forecast
3 Sailing
1 Arrival
```{r Peeling, echo = FALSE, warning=FALSE}
A <- peeling(vars_def = captain_vars1, hgm = captain_hgm, hg_rel_names = captain_rel_names, elim_order = c(8,4,7,2,6,5,3,1), verbose = TRUE )
bcaPrint(A)
round(belplau(A), digits = 2)
```