*support-except / evidence-except*algorithm (see [1] et al) and thus is bounded by the limitation that the network must be a polytree (a directed acyclic graph with exactly one path from any node to another). Add nodes to it by calling [addNode] then initialize the beliefs network through [initBeliefs]. Now query things by calling the functions [evidence], [support], or [infer].Suppose one wanted to try the example in Yudkowsky's site:

1% of women at age forty who participate in routine screening have breast cancer. 80% of women with breast cancer will get positive mammographies. 9.6% of women without breast cancer will also get positive mammographies. A woman in this age group had a positive mammography in a routine screening. What is the probability that she actually has breast cancer?Using the code below one could build the Bayesian network like so:

addNode bc {} {s} 0.01 "Have Breast Cancer" addNode s {bc} {} {0.80 0.096} "Screened Positive"When combined these two create a two node network that look like:

(bc) -> (s)Node

**bc**has a probability of 0.01, corresponding with 1% of all women. Node

**s**has a single parent,

**bc**. The probability that

**s**is true given

**bc**is 0.80; its probability of truth when

**bc**is false is 0.096. Now one can use the network to answer the question if she actually has cancer by calling:

puts [infer +bc +s]which means "if

**s**is true, what is the probability that

**bc**is also true?" Assuming that your computer is not broken Tcl will respond with the correct answer:

0.0776397515528Here is a longer example of what Bayesian networks can do. In our fictional world 20% of all programmers

**Know Tcl**(P(kt) = 0.20). 25% of all programmers also

**Know Python**(P(kp) = 0.25). Note that it is possible for a programmer to know both Tcl and Python. A subset of these programmers are also

**Language Lawyers**. Its

*conditional probability table*is:

kt | kp | P(ll) ----------------- T | T | 0.80 F | T | 0.75 T | F | 0.50 F | F | 0.20What this means is "if someone knew both Tcl and Python, the odds that he is a language lawyer are 80%". If instead he knew neither language then there is only a 20% chance he is a language lawyer. Note that this conditional table is written such that the first parent node varies in truthhood before the others. Also in this world are

**Operating System Geeks**. Its conditional probability table is:

kt | kp | P(osg) ----------------- T | T | 0.60 F | T | 0.58 T | F | 0.30 F | F | 0.05Finally there are those who are

**Hireable**based upon their skills with operating systems. Its table is merely:

osg | P(h) ----------- T | 0.95 F | 0.33Graphically this node looks like (pardon the ASCII art):

(kt) (kp) | \/ | v /\ v (ll) (osg) ---> (h)First set up the network like so:

addNode kt {} {ll osg} 0.20 "Knows Tcl" addNode kp {} {ll osg} 0.25 "Knows Python" addNode ll {kt kp} {} {0.80 0.75 0.50 0.20} "Language Lawyer" addNode osg {kt kp} {h} {0.60 0.58 0.30 0.05} "OS Geek" addNode h {osg} {} {0.95 0.33} "Hireable"Now make some queries. Suppose you wanted to know what percentage of all programmers are hireable. Phrase the query like this:

puts [evidence +h]and the Bayesian network responds with 0.46702. What if you wanted to know how many non-OS geeks know Python but not Tcl:

puts [support ~osg +kp~kt]The network reports the answer to be 0.42. The complete code (blah blah oll blah) below:

# An implementation of a a Bayesian belief network by way of # support-except and evidence-except algorithm by Jason Tang # ([email protected]). The network is limited to just polytrees. # Populates the table of calculated beliefs using values given by the # Bayesian network. proc initBeliefs {} { array unset ::beliefs foreach n $::bayes(nodes) { if {$::bayes($n:p) == {}} { # head node set ::beliefs(+$n) $::bayes($n:w) set ::beliefs(~$n) [not $::bayes($n:w)] } else { # iterate through the parents and populate beliefs with # given evidence set weightNum 0 foreach given [permutate $::bayes($n:p)] { set given [join $given {}] set ::beliefs(+$n|$given) [lindex $::bayes($n:w) $weightNum] set ::beliefs(~$n|$given) [not $::beliefs(+$n|$given)] incr weightNum } } } } # Given a child node and some condition by the parents, calculates the # probability of that child existing. $a must be of form "+X" (to # indicate that state X should be true) or "~X" (to indicate # falsehood). $given may be any complex truthhood (e.g., "+X~Y~Z") as # long as all of the states are the same distance away from $a. proc support {a given} { if {$given == {}} { # asked for a conditional variable, but a has no parents return {} } if {![info exists ::beliefs($a|$given)]} { set x [string range $a 1 end] set tmp $given while {[regexp {\A.([^+~]+)(.*)} $tmp foo g tmp]} { lappend gList $g } if [elemSubset $gList $::bayes($x:p)] { # condition x for just $given and no other variables # within x's parentage set prob 0 foreach xgiven [permutate $::bayes($x:p)] { set xgiven [join $xgiven {}] if [truthSubset $given $xgiven] { set p $::beliefs(+$x|$xgiven) foreach r [truthRemainder $given $xgiven] { set p [expr {double($p * [evidence $r])}] } set prob [expr {$prob + $p}] } } } else { # search through parents until a path is found set foundPath 0 foreach p $::bayes($x:p) { set prob0 [support +$p $given] if {$prob0 != {}} { set prob1 [support ~$p $given] set prob [expr {[support +$x +$p] * $prob0 + [support +$x ~$p] * $prob1}] set foundPath 1 break } } if !$foundPath { error "no path found from $x to $given" } } set ::beliefs(+$x|$given) $prob set ::beliefs(~$x|$given) [not $prob] } # puts "support returns for $a|$given: $::beliefs($a|$given)" return $::beliefs($a|$given) } # Calculates the probability the truthhood of some state. $a must be # of form "+X" (to indicate that state X should be true) or "~X" (to # indicate falsehood). proc evidence {a} { if {![info exists ::beliefs($a)]} { set x [string range $a 1 end] set prob 0.0 foreach given [permutate $::bayes($x:p)] { set p [support +$x [join $given {}]] foreach g $given { set p [expr {double($p * [evidence $g])}] } set prob [expr {$prob + $p}] } set ::beliefs(+$x) $prob set ::beliefs(~$x) [not $prob] } # puts "evidence returns for $a: $::beliefs($a)" return $::beliefs($a) } # Uses Bayes' theorem to infer some parent condition ($a) given the # truthhood of a single child state ($given). Both $a and $given must # be a single state of form "+X" (to indicate that state X should be # true) or "~X" (to indicate falsehood). proc infer {a given} { return [expr {[support $given $a] * [evidence $a] / [evidence $given]}] } ###################################################################### # Bayesian utilities # Given a list of nodes, returns a permutation of them alternating # between true and false. For example, given the list "a b c" this # function returns: # +a+b+c ~a+b+c +a~b+c ~a~b+c +a+b~c ~a+b~c +a~b~c ~a~b~c # meaning {a, b, c}, {not a, b, c}, {a, not b, c}, etc. proc permutate {nodes} { if {$nodes == {}} { error "permutated across nothing!" } if {[llength $nodes] == 1} { return [list [list "+$nodes"] [list "~$nodes"]] } else { set head [lindex $nodes 0] foreach n [permutate [lrange $nodes 1 end]] { lappend retlist [concat "+$head" $n] [concat "~$head" $n] } return $retlist } } # returns non-zero if every element in needle is in the haystack list proc elemSubset {needle haystack} { foreach n $needle { if {[lsearch -exact $haystack $n] == -1} { return 0 } } return 1 } # Returns true if the truth $needle (e.g., "+a~b") is a subset of the # truth $haystack (e.g., "+a~x+y+b~z") proc truthSubset {needle haystack} { while {[regexp {\A(.[^+~]+)(.*)} $haystack foo h haystack]} { lappend stackList $h } while {[regexp {\A(.[^+~]+)(.*)} $needle foo n needle]} { if {[lsearch -exact $stackList $n] == -1} { return 0 } } return 1 } # Given a truth $needle (e.g., "+a~b") and a truth $haystack (e.g., # "+a~x+y+b~z") return the truth without any from $needle in list form # (in this case, {~x +y ~z}) proc truthRemainder {needle haystack} { while {[regexp {\A(.[^+~]+)(.*)} $needle foo n needle]} { lappend needleList $n } set remainder "" while {[regexp {\A(.[^+~]+)(.*)} $haystack foo h haystack]} { if {[lsearch -exact $needleList $h] == -1} { lappend remainder $h } } return $remainder } # Takes a probability and returns its inverse. proc not {p} { return [expr {1.0 - $p}] } # adds a node to the network. be aware that weights must be phrased a # certain way proc addNode {shortName parents children weights {fullName ""}} { if {$fullName == ""} { set fullName $shortName } set ::bayes($shortName) $fullName set ::bayes($shortName:p) $parents set ::bayes($shortName:c) $children set ::bayes($shortName:w) $weights lappend ::bayes(nodes) $shortName } ###################################################################### # start of main script below # do the breast cancer example addNode bc {} {s} 0.01 "Have Breast Cancer" addNode s {bc} {} {0.80 0.096} "Screened Positive" initBeliefs puts "Percent who have breast cancer given a positive screening: [infer +bc +s]" # now do the Tcl/Python example # first clear away the old Bayesian network array unset ::bayes # then populate it with nodes addNode kt {} {ll osg} 0.20 "Knows Tcl" addNode kp {} {ll osg} 0.25 "Knows Python" addNode ll {kt kp} {} {0.80 0.75 0.50 0.20} "Language Lawyer" addNode osg {kt kp} {h} {0.60 0.58 0.30 0.05} "OS Geek" addNode h {osg} {} {0.95 0.33} "Hireable" # initialize the beliefs network initBeliefs # now make queries puts "Percent of all programmers who are hireable: [evidence +h]" puts "Percent hireable who know Tcl and Python: [support +h +kt+kp]" puts "Percent of non-OS geeks who know just Python and not Tcl: [support ~osg +kp~kt]" puts "Percent who know Tcl but are not language lawyers: [infer +kt ~ll]"

Return to Jason Tang

See also