;; --------------------------------------------------------------------
;; Helper functions
(define (bool->num x)
(if x 1 0))
(define (last xs)
(first (reverse xs)))
(define (compose f g)
(lambda (x)
(f (g x))))
(define (zip xs1 xs2)
(if (or (is_null xs1) (is_null xs2)) '()
(pair
(pair (first xs1) (pair (first xs2) '()))
(zip (rest xs1) (rest xs2)))))
;; --------------------------------------------------------------------
;; Data structures
;; responsibility measure = [title, func]
(define measure->title first)
(define measure->func rest)
;; world = [agent A, agent B, ..., effect]
(define world->A first)
(define world->B second)
(define world->effect last)
;; scenario = [actual-world, counterfactual-world, joint prob]
(define scenario->actual first)
(define scenario->counterfactual second)
(define scenario->prob third)
(define (scenario->direction s)
(- (world->effect (scenario->counterfactual s))))
;; --------------------------------------------------------------------
;; Responsibility measures (by Tobias Gerstenberg)
(define (unnormalized-responsibility scenarios consistent?)
(let* ([consistent-scenarios (filter consistent? scenarios)])
(sum (map (lambda (scenario)
(* (scenario->direction scenario)
(scenario->prob scenario)))
consistent-scenarios))))
(define (normalized-responsibility scenarios consistent?)
(let ([consistent-scenarios (filter consistent? scenarios)])
(/ (unnormalized-responsibility scenarios consistent?)
(sum (map scenario->prob consistent-scenarios)))))
(define (unnormalized-inverted-responsibility scenarios consistent?)
(* -1 (unnormalized-responsibility scenarios
(lambda (s) (not (consistent? s))))))
(define (normalized-inverted-responsibility scenarios consistent?)
(* -1 (normalized-responsibility scenarios
(lambda (s) (not (consistent? s))))))
(define responsibility-measures
(list
(pair "Unnormalized responsibility: " unnormalized-responsibility)
(pair "Normalized responsibility: " normalized-responsibility)
(pair "Unnormalized inverted responsibility: " unnormalized-inverted-responsibility)
(pair "Normalized inverted responsibility: " normalized-inverted-responsibility)))
(define (show-responsibility-measures scenarios scenario-consistent?)
(for-each
(lambda (responsibility-measure)
(display (measure->title responsibility-measure)
((measure->func responsibility-measure) scenarios scenario-consistent?)))
responsibility-measures))
;; --------------------------------------------------------------------
;; Nearby counterfactuals
;; "perturb-world" samples or perturbs a given random world (mapping names
;; to values) using interventions (mapping names to functions). The
;; pre-intervention distribution on nearby worlds is defined by noisily
;; conditioning on the actual world.
(define perturb-world
(mem
(lambda (world interventions noise)
;; "counterfactual-wrap" makes a function f take as additional
;; (first) argument a name. Before applying the function, we look
;; up this name in the given list of interventions. If an
;; intervention is given, there must also be a value in the
;; world for this name. We apply the intervention function to
;; this value and return the result. If no intervention is given,
;; we simply apply f to its arguments.
(define (counterfactual-wrap f)
(lambda args
(let* ([name (first args)]
[func-args (rest args)]
[intervention-pair (assoc name interventions)])
(if (eq? intervention-pair #f)
(apply f func-args)
(let* ([intervention-func (rest intervention-pair)]
[world-value (rest (assoc name world))])
(intervention-func world-value))))))
(define flip0 (counterfactual-wrap flip))
(define and0 (counterfactual-wrap and))
(define or0 (counterfactual-wrap or))
;; "noisy-obs" takes a name and a target value as arguments. We look up
;; the observed value for the name in the random world. If it is found,
;; we apply the usual noisy-=. Otherwise, we always return true.
(define (noisy-obs name target-value)
(let ([world-pair (assoc name world)])
(if (eq? world-pair #f)
#t
(flip (if (equal? target-value (rest world-pair))
1.0
noise)))))
;; Below we define a simple causal model. Using the functions defined
;; above, we can noisily condition on the actual world, and apply interventions
;; to all variables in the model.
(enumeration-query
(define A (flip0 'A .1))
(define B (flip0 'B .9))
(define E (and0 'E A B))
(list (pair 'A A)
(pair 'B B)
(pair 'E E))
(and (noisy-obs 'A A)
(noisy-obs 'B B)
(noisy-obs 'E E))))))
;; "counterfactual-dist" computes the joint distribution on actual and
;; counterfactual worlds, where counterfactuals are defined using the
;; "perturb-world" function above (parameterized by user-provided
;; interventions and observation noise).
(define (counterfactual-dist interventions noise)
(enumeration-query
(define prior-world (apply multinomial (perturb-world '() '() noise)))
(define cf-world (apply multinomial (perturb-world prior-world interventions noise)))
(list (map (compose bool->num rest) prior-world)
(map (compose bool->num rest) cf-world))
#t))
;; "joint-dist->scenarios" converts the joint distribution into a format
;; that can be read by the responsibility measures defined above.
(define (joint-dist->scenarios joint-dist)
(map
(lambda (bin)
(append (first bin)
(rest bin)))
(apply zip joint-dist)))
;; --------------------------------------------------------------------
;; Example
;; "world" is supposed to represent what happened in the "actual" world.
(define world
'((A . #f)
(B . #f)
(E . #f)))
;; "interventions" is a list of variable ("agent") names and functions that
;; intervene on the value of variable and return a counterfactual value.
(define interventions
(list (pair 'A (lambda (a) (not a)))))
;; "scenario-consistent?" returns true if the value of 'A considered
;; in the prior world in a scenario is the same as in the actual world.
;; This is used in some responsbility measures.
(define (scenario-consistent? scenario)
(equal? (world->A (scenario->actual scenario))
(bool->num (rest (assoc 'A world)))))
;; Looking at the joint distribution, the most likely scenario is that
;; E is 0 in the actual world because A was 0, but intervening on A makes
;; E be 1.
(define joint-dist (counterfactual-dist interventions .4))
(barplot joint-dist "joint probs of actual & counterfactual worlds")
;; As a result, A carries significant responsibility for the fact that
;; E was 0.
(define scenarios (joint-dist->scenarios joint-dist))
(show-responsibility-measures scenarios scenario-consistent?)
The above will take some changes to be correct. A first stab looks like this:
(define (run-world world interventions observations noise)
(define (counterfactual-wrap f is-deterministic)
(lambda args
(let* ([name (first args)]
[func-args (rest args)]
[intervention-pair (assoc name interventions)])
(if (eq? intervention-pair #f)
(if is-deterministic
(apply f func-args)
(let ([world-pair (assoc name world)])
(if (eq? world-pair #f)
(apply f func-args)
(rest world-pair))))
(let* ([intervention-func (rest intervention-pair)]
[world-value (rest (assoc name world))])
(intervention-func world-value))))))
(define (noisy-obs name target-value)
(let ([obs-pair (assoc name observations)])
(if (eq? obs-pair #f)
#t
(flip (if (equal? target-value (rest obs-pair))
1.0 ;; could change to (- 1 noise)
noise)))))
(define flip0 (counterfactual-wrap flip #f))
(define and0 (counterfactual-wrap and #t))
(define or0 (counterfactual-wrap or #t))
(enumeration-query
(define A (flip0 'A .1))
(define B (flip0 'B .9))
(define E (and0 'E A B))
(list (pair 'A A)
(pair 'B B)
(pair 'E E))
(and (noisy-obs 'A A)
(noisy-obs 'B B)
(noisy-obs 'E E))))
(define observations
'((A . #f)
(B . #f)
(E . #f)))
(define interventions
(list (pair 'A (lambda (a) (not a)))))
(define noise .05)
(define prior-on-worlds (run-world '() '() '() .05))
(barplot prior-on-worlds "Prior on worlds")
References: