Type get-interaction-sign.
This commit is contained in:
Sergiu Ivanov
parent
3e1dca8d63
commit
2424e155fd
2 changed files with 91 additions and 72 deletions
139
networks.rkt
139
networks.rkt
|
|
@ -26,7 +26,7 @@
|
|||
build-all-states build-all-boolean-states build-all-01-states
|
||||
|
||||
list-syntactic-interactions build-syntactic-interaction-graph
|
||||
interaction?
|
||||
interaction? get-interaction-sign
|
||||
)
|
||||
|
||||
(define-type (State a) (VariableMapping a))
|
||||
|
|
@ -362,6 +362,71 @@
|
|||
(define n2 (network-form->network/any (network-form n-multi 123-doms)))
|
||||
(check-false (interaction? n2 'x 'y))
|
||||
(check-true (interaction? n2 'y 'x))))
|
||||
|
||||
(: get-interaction-sign (All (a) (-> (Network a) Variable Variable (Option Integer))))
|
||||
(define (get-interaction-sign network x y)
|
||||
(define doms (network-domains network))
|
||||
(define dom-x (hash-ref doms x))
|
||||
(define dom-y (hash-ref doms y))
|
||||
(define y-func (hash-ref (network-functions network) y))
|
||||
(define (collect-impacts-on-y [st : (State a)])
|
||||
;; The way in which the values are ordered in the domains gives
|
||||
;; a total order on these values. This means that considering
|
||||
;; pairs of consecutive values of x is sufficient for testing the
|
||||
;; sign of the interaction.
|
||||
(define x-states (for/list : (Listof (State a))
|
||||
([x-val (in-list dom-x)])
|
||||
(hash-set st x x-val)))
|
||||
(for/list : (Listof (U '< '> '=))
|
||||
([st1 (in-list x-states)]
|
||||
[st2 (in-list (cdr x-states))])
|
||||
(define y1-idx (assert-type (index-of dom-y (y-func st1)) Index))
|
||||
(define y2-idx (assert-type (index-of dom-y (y-func st2)) Index))
|
||||
(cond
|
||||
[(< y1-idx y2-idx) '<]
|
||||
[(> y1-idx y2-idx) '>]
|
||||
[else '=])))
|
||||
(define states-not-x (build-all-states (hash-remove doms x)))
|
||||
(define interactions
|
||||
(remove-duplicates
|
||||
(for/list : (Listof (U '< '> '= Zero))
|
||||
([st (in-list states-not-x)])
|
||||
(define impacts (remove-duplicates (collect-impacts-on-y st)))
|
||||
(cond
|
||||
[(and (member '< impacts) (not (member '> impacts))) '<]
|
||||
[(and (member '> impacts) (not (member '< impacts))) '>]
|
||||
[(equal? impacts '(=)) '=]
|
||||
[else 0]))))
|
||||
(cond
|
||||
[(and (member '< interactions) (not (member '> interactions))) 1]
|
||||
[(and (member '> interactions) (not (member '< interactions))) -1]
|
||||
[(equal? interactions '(=)) #f]
|
||||
[else 0]))
|
||||
|
||||
(module+ test
|
||||
(test-case "get-interaction-sign"
|
||||
(define n1 (forms->boolean-network
|
||||
(hash 'x '(not y)
|
||||
'y 'x
|
||||
'z '(and y z)
|
||||
't '(or (and (not x) y)
|
||||
(and x (not y))))))
|
||||
(check-equal? (get-interaction-sign n1 'x 'y) 1)
|
||||
(check-equal? (get-interaction-sign n1 'y 'x) -1)
|
||||
(check-false (get-interaction-sign n1 'x 'z))
|
||||
(check-equal? (get-interaction-sign n1 'y 'z) 1)
|
||||
(check-equal? (get-interaction-sign n1 'x 't) 0)
|
||||
(define n-multi (hash 'x '(min (+ y 1) 2)
|
||||
'y '(max (- y 1) 0)
|
||||
'z '(- 2 y)
|
||||
't '(abs (- y 1))))
|
||||
(define 123-doms (make-same-domains '(x y z t) '(0 1 2)))
|
||||
(define n2 (network-form->network/any (network-form n-multi 123-doms)))
|
||||
(check-false (get-interaction-sign n2 'x 'y))
|
||||
(check-equal? (get-interaction-sign n2 'y 'x) 1)
|
||||
(check-equal? (get-interaction-sign n2 'y 'z) -1)
|
||||
(check-equal? (get-interaction-sign n2 'y 't) 0)
|
||||
(check-equal? (get-interaction-sign n2 'y 'y) 1)))
|
||||
)
|
||||
|
||||
(require 'typed)
|
||||
|
|
@ -378,10 +443,7 @@
|
|||
[struct dynamics ([network network?]
|
||||
[mode mode?])])
|
||||
;; Functions
|
||||
(contract-out [get-interaction-sign (-> network? variable? variable? (or/c #f -1 0 1))]
|
||||
[build-interaction-graph (-> network? graph?)]
|
||||
[build-interaction-graph/form (-> network-form? graph?)]
|
||||
[build-signed-interaction-graph (-> network? graph?)]
|
||||
(contract-out [build-signed-interaction-graph (-> network? graph?)]
|
||||
[build-signed-interaction-graph/form (-> network-form? graph?)]
|
||||
[make-asyn (-> (listof variable?) mode?)]
|
||||
[make-syn (-> (listof variable?) mode?)]
|
||||
|
|
@ -523,73 +585,6 @@
|
|||
;;; Inferring interaction graphs
|
||||
;;; ============================
|
||||
|
||||
;;; Given two variables x and y of a network f, checks whether they
|
||||
;;; interact, and if they interact, returns 1 if increasing x leads to
|
||||
;;; an increase in y, -1 if it leads to a decrease in y, and 0 if it
|
||||
;;; can lead to both. If x has no impact on y, returns #f.
|
||||
;;;
|
||||
;;; Use interaction? if you only need to know whether two variables
|
||||
;;; interact, because interaction? will be often faster.
|
||||
(define (get-interaction-sign network x y)
|
||||
(define doms (network-domains network))
|
||||
(define dom-x (hash-ref doms x))
|
||||
(define dom-y (hash-ref doms y))
|
||||
(define y-func (hash-ref (network-functions network) y))
|
||||
(define (collect-impacts-on-y st)
|
||||
;; The way in which the values are ordered in the domains gives
|
||||
;; a total order on these values. This means that considering
|
||||
;; pairs of consecutive values of x is sufficient for testing the
|
||||
;; sign of the interaction.
|
||||
(define x-states (for/list ([x-val (in-list dom-x)])
|
||||
(hash-set st x x-val)))
|
||||
(for/list ([st1 (in-list x-states)]
|
||||
[st2 (in-list (cdr x-states))])
|
||||
(define y1-idx (index-of dom-y (y-func st1)))
|
||||
(define y2-idx (index-of dom-y (y-func st2)))
|
||||
(cond
|
||||
[(< y1-idx y2-idx) '<]
|
||||
[(> y1-idx y2-idx) '>]
|
||||
[else '=])))
|
||||
(define states-not-x (build-all-states (hash-remove doms x)))
|
||||
(define interactions
|
||||
(remove-duplicates
|
||||
(for/list ([st (in-list states-not-x)])
|
||||
(define impacts (remove-duplicates (collect-impacts-on-y st)))
|
||||
(cond
|
||||
[(and (member '< impacts) (not (member '> impacts))) '<]
|
||||
[(and (member '> impacts) (not (member '< impacts))) '>]
|
||||
[(equal? impacts '(=)) '=]
|
||||
[else 0]))))
|
||||
(cond
|
||||
[(and (member '< interactions) (not (member '> interactions))) 1]
|
||||
[(and (member '> interactions) (not (member '< interactions))) -1]
|
||||
[(equal? interactions '(=)) #f]
|
||||
[else 0]))
|
||||
|
||||
(module+ test
|
||||
(test-case "get-interaction-sign"
|
||||
(define n1 (forms->boolean-network
|
||||
(hash 'x '(not y)
|
||||
'y 'x
|
||||
'z '(and y z)
|
||||
't '(or (and (not x) y)
|
||||
(and x (not y))))))
|
||||
(check-equal? (get-interaction-sign n1 'x 'y) 1)
|
||||
(check-equal? (get-interaction-sign n1 'y 'x) -1)
|
||||
(check-false (get-interaction-sign n1 'x 'z))
|
||||
(check-equal? (get-interaction-sign n1 'y 'z) 1)
|
||||
(check-equal? (get-interaction-sign n1 'x 't) 0)
|
||||
(define n-multi (hash 'x '(min (+ y 1) 2)
|
||||
'y '(max (- y 1) 0)
|
||||
'z '(- 2 y)
|
||||
't '(abs (- y 1))))
|
||||
(define 123-doms (make-same-domains '(x y z t) '(0 1 2)))
|
||||
(define n2 (network-form->network/any (network-form n-multi 123-doms)))
|
||||
(check-false (get-interaction-sign n2 'x 'y))
|
||||
(check-equal? (get-interaction-sign n2 'y 'x) 1)
|
||||
(check-equal? (get-interaction-sign n2 'y 'z) -1)
|
||||
(check-equal? (get-interaction-sign n2 'y 't) 0)
|
||||
(check-equal? (get-interaction-sign n2 'y 'y) 1)))
|
||||
|
||||
;;; Given a network, builds its interaction graph. The graph has
|
||||
;;; variables as nodes and has a directed edge from x to y if
|
||||
|
|
|
|||
|
|
@ -434,6 +434,30 @@ values for @racket[y].}
|
|||
(interaction? bn 'b 'a)))
|
||||
]}
|
||||
|
||||
@defproc[(get-interaction-sign [network (Network a)]
|
||||
[x Variable]
|
||||
[y Variable])
|
||||
(Option Integer)]{
|
||||
|
||||
Given two variables @racket[x] and @racket[y] of @racket[network], checks
|
||||
whether they interact, and if they interact, returns 1 if increasing @racket[x]
|
||||
leads to an increase in @racket[y], -1 if it leads to a decrease in @racket[y],
|
||||
and 0 if it can lead to both. If @racket[x] has no impact on @racket[y], returns @racket[#f].
|
||||
|
||||
The values in the domains are ordered according to the order in which they are
|
||||
listed in @racket[network].
|
||||
|
||||
Since @racket[get-interaction-sign] needs to check all possible interactions
|
||||
between @racket[x] and @racket[y], it is more costly than calling
|
||||
@racket[interaction?].
|
||||
|
||||
@ex[
|
||||
(let ([bn (forms->boolean-network #hash((a . (and a b))
|
||||
(b . (not b))))])
|
||||
(values (get-interaction-sign bn 'a 'b)
|
||||
(get-interaction-sign bn 'b 'a)
|
||||
(get-interaction-sign bn 'b 'b)))
|
||||
]}
|
||||
@section{Tabulating functions and networks}
|
||||
|
||||
@section{Constructing functions and networks}
|
||||
|
|
|
|||
Loading…
Reference in a new issue