Captain_Example

Claude Boivin1

2018-06-20. Revised 2020-02-09

Summary

The Captain’s Problem has been introduced by R. G. Almond 2 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 3.

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}

# library(dst)
load("data/ads.rda")
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)
##                                                                                                                         ads_rel
## 1 6 3 3 + 5 3 2 + 5 2 3 + 4 3 1 + 4 2 2 + 4 1 3 + 3 3 0 + 3 2 1 + 3 1 2 + 3 0 3 + 2 2 0 + 2 1 1 + 2 0 2 + 1 1 0 + 1 0 1 + 0 0 0
## 2                                                                                                                         frame
##   specnb mass
## 1      1    1
## 2      2    0

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}.

load("data/dlfm.rda")
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)
##                                                                                                                                                        dlfm_rel
## 1 3 true foul true + 2 true foul false + 2 true fair true + 2 false foul true + 1 true fair false + 1 false foul false + 1 false fair true + 0 false fair false
## 2                                                                                                                                                         frame
##   specnb mass
## 1      1    1
## 2      2    0

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. \(Ω_A\) = {0,1,2,3,4,5,6}; \(Ω_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.

load("data/swr.rda")
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)
##                                                   swr_rel specnb mass
## 1 2 foul true + 1 foul false + 1 fair true + 0 fair false      1  0.9
## 2                                                   frame      2  0.1

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

load("data/fw.rda")
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)
##                  fw_rel specnb mass
## 1 foul foul + fair fair      1  0.8
## 2                 frame      2  0.2

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

load("data/mrt.rda")
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)
##                                 mrt_rel specnb mass
## 1  true true + false true + false false      1  0.1
## 2 true false + false true + false false      2  0.7
## 3                                 frame      3  0.2

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

load("data/mrf.rda")
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)
##                                mrf_rel specnb mass
## 1  true true + true false + false true      1  0.2
## 2 true true + true false + false false      2  0.2
## 3                                frame      3  0.6

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.

mr_rel <- nzdsr(dsrwon(mrt_rel, mrf_rel)) 
bcaPrint(mr_rel)
##                                  mr_rel specnb mass
## 1                true true + false true      1 0.02
## 2               true false + false true      2 0.14
## 3               true true + false false      3 0.02
## 4              true false + false false      4 0.14
## 5   true true + true false + false true      5 0.04
## 6  true true + true false + false false      6 0.04
## 7  true true + false true + false false      7 0.06
## 8 true false + false true + false false      8 0.42
## 9                                 frame      9 0.12

Input of evidence

1: Loading delay

\(Ω_L\) = {true, false}. m({true}) = 0.5 ; m({false})= 0.3 ; m({true}, {false}) = 0.2

l_rel <- bca(f = matrix(c(1,0,0,1,1,1), ncol = 2, byrow = TRUE), m = c(0.3, 0.5, 0.2), cnames = c("true", "false"), varnb = 4, varnames = "Loading")
## Warning in bca(f = matrix(c(1, 0, 0, 1, 1, 1), ncol = 2, byrow = TRUE), :
## Parameter name 'f' is deprecated. Use 'tt' instead.
## Warning in bca(f = matrix(c(1, 0, 0, 1, 1, 1), ncol = 2, byrow = TRUE), :
## Parameter name 'varnb' is deprecated. Use 'idvar' instead.
bcaPrint(l_rel)
##   l_rel specnb mass
## 1  true      1  0.3
## 2 false      2  0.5
## 3 frame      3  0.2

Evidence 2: Forecast of Weather

\(Ω_W\)= {foul, fair}. m({foul}) = 0.2 ; m({fair})= 0.6 ; m({foul}, {fair}) = 0.2

f_rel <- bca(f = matrix(c(1,0,0,1,1,1), ncol = 2, byrow = TRUE), m = c(0.2, 0.6, 0.2), cnames = c("foul", "fair"), varnb = 5, varnames = "Forecast")
## Warning in bca(f = matrix(c(1, 0, 0, 1, 1, 1), ncol = 2, byrow = TRUE), :
## Parameter name 'f' is deprecated. Use 'tt' instead.
## Warning in bca(f = matrix(c(1, 0, 0, 1, 1, 1), ncol = 2, byrow = TRUE), :
## Parameter name 'varnb' is deprecated. Use 'idvar' instead.
bcaPrint(f_rel)
##   f_rel specnb mass
## 1  foul      1  0.2
## 2  fair      2  0.6
## 3 frame      3  0.2

Evidence 3: Maintenance before sailing

\(Ω_M\) = {true, false}, m({true}) = 0 ; m({false})= 1 .

m_rel <- bca(f = matrix(c(1,0,0,1), ncol = 2, byrow = TRUE), m = c(0, 1), cnames = c("true", "false"), varnb = 6, varnames = "Maintenance")
## Warning in bca(f = matrix(c(1, 0, 0, 1), ncol = 2, byrow = TRUE), m = c(0, :
## Parameter name 'f' is deprecated. Use 'tt' instead.
## Warning in bca(f = matrix(c(1, 0, 0, 1), ncol = 2, byrow = TRUE), m = c(0, :
## Parameter name 'varnb' is deprecated. Use 'idvar' instead.
bcaPrint(m_rel)
##   m_rel specnb mass
## 1  true      1    0
## 2 false      2    1

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 4 to produce a bipartite graph corresponding to the desired hypergraph.

# 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_incidence_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)
}
## 
## Attaching package: 'igraph'
## The following objects are masked from 'package:stats':
## 
##     decompose, spectrum
## The following object is masked from 'package:base':
## 
##     union

Calculations to obtain the belief function of the Arrival delay

# variables numbers
N <- 1:8
# Elimination order of variables. The goal: Arrival
elim_order <- c(8,7,6,1,5,4,3,2)
var_to_elim <- rownames(captain_hgm)[order(elim_order)]
#
# 1: first step
# first var to eliminate
var_to_elim[1] # Loading (4)
## [1] "Loading"
irel_to_elim<- captain_hgm["Loading",]*1:ncol(captain_hgm)
rels_nb <- irel_to_elim[irel_to_elim>0]
#
## To do: find which rel to extend (here, it is E1)
# extend R6 (Z7_T EN APL)
l_ext <- extmin(get(captain_rel_names[6]), get(captain_rel_names[2])) 
# combine E1, R2
# use length(captain_rel_names) to assign the next relation nb
rel_2_6 <- nzdsr(dsrwon(l_ext, get(captain_rel_names[2]), relnb = 1+length(captain_rel_names)) )
# eliminate the variable "Loading" (4)
rel_9 <- elim(rel_2_6, xnb = order(elim_order)[1])
#
# update hg and relations names
# remove R2 and E7, add R9
R9 <- 1*1:8 %in% rel_9$infovar[,1]
captain_hgm1 <- cbind(captain_hgm[,-c(2,6)], R9)
captain_rel_names1 <- c(captain_rel_names[-c(2,6)], "rel_9")
captain_var_names1 <- captain_var_names[-order(elim_order)[1]]
#
## second step eliminate var "Repairs" (8)
var_to_elim[2] 
## [1] "Repairs"
order(elim_order)[2] # Repairs (8)
## [1] 8
irel_to_elim<- captain_hgm1[var_to_elim[2],]*1:ncol(captain_hgm1)
rels_nb <- irel_to_elim[irel_to_elim>0]
# find variables numbers of each relation to obtain the space to construct
rels_names = captain_rel_names1[rels_nb]
yv1 = get(rels_names[1])$infovar
yv2 = get(rels_names[2])$infovar
yv=rbind(yv1,yv2)
yinfov = doubles(yv)
infovar <- yinfov[order(yinfov[,1]),]
#
# extract valuenames
infovalues <- captain_vars1[infovar[,1]]

# extend the two relations before combining them
# 1. making an empty reference relation with mass(frame) = 1 and
# extending a bca to it.
# 1: construct the tt matrix
init_tt= matrix(rep(1,10),nrow=1, 
dimnames =list(NULL, c("3", "2", "1", "0", 
"false", "true",  "fair","foul",  "false", "true")) )
# 2: mass values
init_spec <- matrix(c(1,1), ncol = 2, 
dimnames = list(NULL, c("specnb", "mass")))
# 3: info on variables
init_info <- matrix(c(3,6,7,8,4,2,2,2), ncol = 2,
dimnames = list(NULL, c("varnb", "size")) )
# 4: the relation
relRef <- bcaRel(tt = init_tt, spec = init_spec,
infovar = init_info, 
varnames = c("Sail", "Maintenance", "Weather", "Repairs"),
 relnb = 10)
# extend the relations
mr_ext <- extmin(get(captain_rel_names1[4]), relRef)
swr_ext <- extmin(get(captain_rel_names1[2]), relRef)
# 3: combine the two relations
# combine extended relations
rel_3_5 <- nzdsr(dsrwon(mr_ext,swr_ext, relnb = 10) ) 
#4 eliminate the variable "Maintenance" (8)
rel_10 <- elim(rel_3_5, xnb = order(elim_order)[2])
#
# update hg and relations names
# remove R3 and R5, add R10
R10 <- 1*1:8 %in% rel_10$infovar[,1]
captain_hgm2 <- cbind(captain_hgm1[,-rels_nb], R10)
captain_rel_names2 <- c(captain_rel_names1[-rels_nb], "rel_10")
#
## Third step eliminate var "Weather" (7)
var_to_elim[3] 
## [1] "Weather"
order(elim_order)[3] # Weather (7)
## [1] 7
irel_to_elim<- captain_hgm2[var_to_elim[3],]*1:ncol(captain_hgm2)
rels_nb <- irel_to_elim[irel_to_elim>0]
# find variables numbers of each relation to obtain the space to construct
rels_names = captain_rel_names2[rels_nb]
yv1 = get(rels_names[1])$infovar
yv2 = get(rels_names[2])$infovar
yv=rbind(yv1,yv2)
yinfov = doubles(yv)
infovar <- yinfov[order(yinfov[,1]),]
#
# extract valuenames
infovalues <- captain_vars1[infovar[,1]]
#
# extend the two relations before combining them
# 1. making an empty reference relation with mass(frame) = 1 and
# extending a bca to it.
# 1: construct the tt matrix
init_tt= matrix(rep(1,10),nrow=1, 
dimnames =list(NULL, c("3", "2", "1", "0","foul", "fair",
"true", "false",  "foul", "fair")) )
# 2: mass values
init_spec <- matrix(c(1,1), ncol = 2, 
dimnames = list(NULL, c("specnb", "mass")))
# 3: info on variables
init_info <- matrix(as.vector(infovar), ncol = 2,
dimnames = list(NULL, c("varnb", "size")) )
# 4: the relation
#
relRef <- bcaRel(tt = init_tt, spec = init_spec,
infovar = init_info, varnames = names(infovalues), relnb = 11)
#
# extend the relations
fw_ext <- extmin(get(captain_rel_names2[rels_nb[1]]), relRef)
rel_10_ext <- extmin(get(captain_rel_names2[rels_nb[2]]), relRef)
# 3: combine the two relations
# combine extended relations
rel_4_10 <- nzdsr(dsrwon(fw_ext,rel_10_ext, relnb = 11) ) 
#
# 4 eliminate the variable "Weather" (7)
rel_11 <- elim(rel_4_10, xnb = order(elim_order)[3])
#
## Fourth step 
var_to_elim[4] 
## [1] "Maintenance"
order(elim_order)[4] # Maintenance (6)
## [1] 6
#eliminate var "Maintenance" (6)
# update hg and relations names
# 
# remove rels_nb R4 and R10, add R11
R11 <- 1*1:8 %in% rel_11$infovar[,1]
captain_hgm3 <- cbind(captain_hgm2[,-rels_nb], R11)
captain_rel_names3 <- c(captain_rel_names2[-rels_nb], "rel_11")
#
irel_to_elim<- captain_hgm3[var_to_elim[4],]*1:ncol(captain_hgm3)
rels_nb <- irel_to_elim[irel_to_elim>0]
# find variables numbers of each relation to obtain the space to construct
rels_names = captain_rel_names3[rels_nb]
yv1 = get(rels_names[1])$infovar
yv2 = get(rels_names[2])$infovar
yv3 = get(rels_names[3])$infovar
yv=rbind(yv1,yv2, yv3)
yinfov = doubles(yv)
infovar <- yinfov[order(yinfov[,1]),]
#
# extract valuenames
## test
infovalues = captain_vars1[infovar[,1]]
#
# extend the relations before combining them
# 1. making an empty reference relation with mass(frame) = 1 and
# extending a bca to it.
# 1: construct the tt matrix
# 
init_tt <- matrix(rep(1,sum(infovar[,2])),nrow=1, dimnames = list(NULL, unlist(infovalues) ) )
# 2: mass values
init_spec <- matrix(c(1,1), ncol = 2, 
dimnames = list(NULL, c("specnb", "mass")))
# 3: info on variables
init_info <- matrix(as.vector(infovar), ncol = 2,
dimnames = list(NULL, c("varnb", "size")) )
# 4: the relation
relRef <- bcaRel(tt = init_tt, spec = init_spec,
infovar = init_info, varnames = names(infovalues), relnb = 12)
# extend the relations (3 relations)
m_ext <- extmin(get(captain_rel_names3[rels_nb[1]]), relRef)
rel_9_ext <- extmin(get(captain_rel_names3[rels_nb[2]]), relRef)
rel_11_ext <- extmin(get(captain_rel_names3[rels_nb[3]]), relRef)
#
# 3: combine the relations
# combine extended relations
rel_3_9 <- nzdsr(dsrwon(m_ext,rel_9_ext, relnb = 12) ) 
rel_3_9_11 <- nzdsr(dsrwon(rel_3_9,rel_11_ext, relnb = 12) ) 
#
# 4 eliminate the variable "Maintenance" (6)
rel_12 <- elim(rel_3_9_11, xnb = order(elim_order)[4])
#
## Fifth step 
var_to_elim[5] 
## [1] "Forecast"
order(elim_order)[5] # Forecast (5)
## [1] 5
#eliminate var "Forecast" (5)
# update hg and relations names
# rels_nb to remove
print(rels_nb) # 3, 4, 5
##  E3  R9 R11 
##   3   4   5
# add R12
R12 <- 1*1:8 %in% rel_12$infovar[,1]
# remove rels_nb E3 and R9, add R11, add R12
captain_hgm4 <- cbind(captain_hgm3[,-rels_nb], R12)
captain_rel_names4 <- c(captain_rel_names3[-rels_nb], "rel_12")
#
irel_to_elim<- captain_hgm4[var_to_elim[5],]*1:ncol(captain_hgm4)
rels_nb <- irel_to_elim[irel_to_elim>0]
# find variables numbers of each relation to obtain the space to construct
rels_names = captain_rel_names4[rels_nb]
yv1 = get(rels_names[1])$infovar
yv2 = get(rels_names[2])$infovar
yv=rbind(yv1,yv2)
yinfov = doubles(yv)
infovar <- yinfov[order(yinfov[,1]),]
#
# extract valuenames
infovalues <- captain_vars1[infovar[,1]]
#
# extend the relations before combining them
# 1. making an empty reference relation with mass(frame) = 1 and
# extending a bca to it.
# 1: construct the tt matrix
##
init_tt <- matrix(rep(1,sum(infovar[,2])),nrow=1, dimnames = list(NULL, unlist(infovalues) ) )
# 2: mass values
init_spec <- matrix(c(1,1), ncol = 2, 
dimnames = list(NULL, c("specnb", "mass")))
# 3: info on variables
init_info <- matrix(as.vector(infovar), ncol = 2,
dimnames = list(NULL, c("varnb", "size")) )
# 4: the relation
relRef <- bcaRel(tt = init_tt, spec = init_spec,
infovar = init_info, varnames = names(infovalues), relnb = 13)
# extend the relations 
f_ext <- extmin(get(captain_rel_names4[rels_nb[1]]), relRef)
#
# 3: combine the relations
# combine extended relations
rel_E2_12 <- nzdsr(dsrwon(f_ext,rel_12, relnb = 13) ) 
# 4 eliminate the variable "Forecast" (5)
rel_13 <- elim(rel_E2_12, xnb = order(elim_order)[5])
#
## sixth step 
var_to_elim[6] 
## [1] "Sailing"
order(elim_order)[6] # Sailing (3)
## [1] 3
#eliminate var "Sailing" (3)
#
# update hg and relations names
# rels_nb to remove
print(rels_nb) # 2,3
##  E2 R12 
##   2   3
# add R13
R13 <- 1*1:8 %in% rel_13$infovar[,1]
# remove rels_nb E3 and R9, add R11, add R12
captain_hgm5 <- cbind(captain_hgm4[,-rels_nb], R13)
captain_rel_names5 <- c(captain_rel_names4[-rels_nb], "rel_13")
#
irel_to_elim<- captain_hgm5[var_to_elim[6],]*1:ncol(captain_hgm5)
rels_nb <- irel_to_elim[irel_to_elim>0]
# find variables numbers of each relation to obtain the space to construct
rels_names = captain_rel_names5[rels_nb]
yv1 = get(rels_names[1])$infovar
yv2 = get(rels_names[2])$infovar
yv=rbind(yv1,yv2)
yinfov = doubles(yv)
infovar <- yinfov[order(yinfov[,1]),]
#
# extract valuenames
infovalues <- captain_vars1[infovar[,1]]
#
# extend the relations before combining them
# 1. making an empty reference relation with mass(frame) = 1 and
# extending a bca to it.
# 1: construct the tt matrix
##
init_tt <- matrix(rep(1,sum(infovar[,2])),nrow=1, dimnames = list(NULL, unlist(infovalues) ) )
# 2: mass values
init_spec <- matrix(c(1,1), ncol = 2, 
dimnames = list(NULL, c("specnb", "mass")))
# 3: info on variables
init_info <- matrix(as.vector(infovar), ncol = 2,
dimnames = list(NULL, c("varnb", "size")) )
# 4: the relation
relRef <- bcaRel(tt = init_tt, spec = init_spec,
infovar = init_info, varnames = names(infovalues), relnb = 14)
# extend the relations 
captain_rel_names5[rels_nb[1]] # " ads_rel"
## [1] "ads_rel"
captain_rel_names5[rels_nb[2]] # rel_13
## [1] "rel_13"
rel_13_ext <- extmin(get(captain_rel_names5[rels_nb[2]]), relRef)   
#
# 3: combine the relations
# combine extended relations
rel_1_13 <- nzdsr(dsrwon(ads_rel,rel_13_ext, relnb = 14, mcores = "no") ) 
# 4 eliminate the variable "SAiling" (3)
rel_14 <- elim(rel_1_13, xnb = order(elim_order)[6])
#
## Step 7 
var_to_elim[7] 
## [1] "Departure"
order(elim_order)[7] # Departure (2)
## [1] 2
#eliminate var "Departure" (2)
#
# update hg and relations names
# rels_nb to remove
print(rels_nb) # 1,2
##     R13 
##   1   2
# add R14
R14 <- 1*1:8 %in% rel_14$infovar[,1]
# remove rels_nb E3 and R9, add R11, add R12
captain_hgm6 <- cbind(captain_hgm5[,-rels_nb], R14)
captain_rel_names6 <- c(captain_rel_names5[-rels_nb], "rel_14")
#
irel_to_elim<- captain_hgm6[var_to_elim[7],]*1:ncol(captain_hgm6)
rels_nb <- irel_to_elim[irel_to_elim>0]
# find variables numbers of each relation to obtain the space to construct
rels_names = captain_rel_names6[rels_nb]
yv1 = get(rels_names[1])$infovar
yv = yv1
if (length(rels_names) > 1 ) {
  yv2 = get(rels_names[2])$infovar
  yv=rbind(yv1,yv2)
} 
yinfov = doubles(yv)
infovar <- yinfov[order(yinfov[,1]),]
#
# extract valuenames
infovalues <- captain_vars1[infovar[,1]]
#
if (length(rels_names) > 1 ) {
# extend the relations before combining them
# 1. making an empty reference relation with mass(frame) = 1 and
# extending a bca to it.
# 1: construct the tt matrix
##
  init_tt <- matrix(rep(1,sum(infovar[,2])),nrow=1, dimnames = list(NULL, unlist(infovalues) ) )
# 2: mass values
  init_spec <- matrix(c(1,1), ncol = 2, 
dimnames = list(NULL, c("specnb", "mass")))
# 3: info on variables
  init_info <- matrix(as.vector(infovar), ncol = 2,
dimnames = list(NULL, c("varnb", "size")) )
# 4: the relation
  relRef <- bcaRel(tt = init_tt, spec = init_spec,
infovar = init_info, varnames = names(infovalues), relnb = 15)
# extend the relations 
  captain_rel_names6[rels_nb[1]] # " rel"
  rel_ext <- extmin(get(captain_rel_names6[rels_nb[1]]), relRef) ## no need to extend. make a check on this case in an algorithm.
  captain_rel_names6[rels_nb[2]] # rel_14
  rel_14_ext <- extmin(get(captain_rel_names6[rels_nb[2]]), relRef)   
#
# 3: combine the relations
# combine extended relations
rel_comb <- nzdsr(dsrwon(rel_ext,rel_14_ext, relnb = 15, mcores = "no") ) 
cat("Results")
}
# 4 eliminate the variable "Sailing" (3)
rel_15 <- elim(rel_14, xnb = order(elim_order)[7]) 
bcaPrint(rel_15)
##                   rel_15 specnb    mass
## 1                      5      1       0
## 2                      3      2 0.02304
## 3                      4      3 0.00864
## 4                      2      4 0.04032
## 5                      1      5 0.06912
## 6                      0      6  0.0432
## 7                  5 + 3      7       0
## 8                  4 + 2      8 0.00864
## 9                  3 + 1      9 0.02304
## 10                 2 + 0     10  0.0144
## 11                 5 + 4     11       0
## 12                 3 + 2     12  0.0612
## 13                 4 + 3     13 0.03384
## 14                 2 + 1     14 0.11592
## 15                 1 + 0     15 0.15768
## 16             5 + 4 + 3     16       0
## 17             4 + 3 + 2     17 0.02736
## 18             3 + 2 + 1     18 0.04176
## 19             2 + 1 + 0     19 0.09216
## 20         5 + 4 + 3 + 2     20   0.006
## 21         4 + 3 + 2 + 1     21 0.07192
## 22         3 + 2 + 1 + 0     22 0.10416
## 23         6 + 5 + 4 + 3     23       0
## 24                 frame     24       0
## 25     5 + 4 + 3 + 2 + 1     25    0.01
## 26     4 + 3 + 2 + 1 + 0     26  0.0436
## 27     6 + 5 + 4 + 3 + 2     27       0
## 28 5 + 4 + 3 + 2 + 1 + 0     28   0.004
## 29 6 + 5 + 4 + 3 + 2 + 1     29       0
belplau(rel_15)
##                        Belief Plausibility    Plty Ratio
## 5                     0.00000      0.02000  2.000000e-02
## 3                     0.02304      0.44992  4.605306e-01
## 4                     0.00864      0.21400  2.158651e-01
## 2                     0.04032      0.64144  6.683895e-01
## 1                     0.06912      0.73336  7.878137e-01
## 0                     0.04320      0.45920  4.799331e-01
## 5 + 3                 0.02304      0.44992  4.605306e-01
## 4 + 2                 0.05760      0.68392  7.257216e-01
## 3 + 1                 0.11520      0.88480  1.000000e+00
## 2 + 0                 0.09792      0.84232  9.337531e-01
## 5 + 4                 0.00864      0.21400  2.158651e-01
## 3 + 2                 0.12456      0.72136  8.239971e-01
## 4 + 3                 0.06552      0.46720  4.999572e-01
## 2 + 1                 0.22536      0.89128  1.150573e+00
## 1 + 0                 0.27000      0.79096  1.083507e+00
## 5 + 4 + 3             0.06552      0.46720  4.999572e-01
## 4 + 3 + 2             0.20304      0.73000  9.159807e-01
## 3 + 2 + 1             0.37440      0.94816  1.515601e+00
## 2 + 1 + 0             0.53280      0.93448  2.000171e+00
## 5 + 4 + 3 + 2         0.20904      0.73000  9.229291e-01
## 4 + 3 + 2 + 1         0.52480      0.95680  2.013468e+00
## 3 + 2 + 1 + 0         0.78600      0.99136  4.632523e+00
## 6 + 5 + 4 + 3         0.06552      0.46720  4.999572e-01
## frame                 1.00000      1.00000 -4.503600e+15
## 5 + 4 + 3 + 2 + 1     0.54080      0.95680  2.083624e+00
## 4 + 3 + 2 + 1 + 0     0.98000      1.00000  5.000000e+01
## 6 + 5 + 4 + 3 + 2     0.20904      0.73000  9.229291e-01
## 5 + 4 + 3 + 2 + 1 + 0 1.00000      1.00000 -4.503600e+15
## 6 + 5 + 4 + 3 + 2 + 1 0.54080      0.95680  2.083624e+00

  1. Retired Statistician, Stat.ASSQ↩︎

  2. 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.↩︎

  3. P. P. Shenoy. Valuation-Based Systems. Third School on Belief Functions and Their Applications, Stella Plage, France. September 30, 2015.↩︎

  4. Csardi G, Nepusz T: The igraph software package for complex network research, InterJournal, Complex Systems 1695. 2006. https://igraph.org↩︎