1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
{-| Module : Graph.Clustering
Description :
Copyright : (c) CNRS, Alexandre Delanoë
License : AGPL (MIT) + CECILL (CEA/CNRS/INRIA)
Maintainer : alexandre+dev@delanoe.org
Stability : experimental
Portability : POSIX
Reference: Article POK de QuaC de G
POK: Parts Overlap Kern
-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Graph.BAC.Scores
where
import Data.Serialize
import Protolude
import Control.Lens
import Data.Set (Set)
import Graph.BAC.Types
import Graph.BAC.Proxemy
import Graph.FGL (degree, edges)
import Data.Graph.Inductive (Node, DynGraph, size, subgraph)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Graph.IGraph as IG
import qualified IGraph.Algorithms.Community as IG
------------------------------------------------------------------------
-- | Main scores functions
------------------------------------------------------------------------
sumConf :: Confluence -> Module -> SumConf
sumConf c m = sum
$ catMaybes [ let c' = Map.lookup (x,y) c in
if c' /= Nothing
then c'
else Map.lookup (y,x) c
| x <- Set.toList m
, y <- Set.toList m
, x < y
]
qualityConf_Module :: Confluence -> Module -> QualityConf
qualityConf_Module c m =
let n = fromIntegral (Set.size m) in
if n <= 1
then 0
else sumConf c m / (n * (n -1) * 0.5)
------------------------------------------------------------------------
sumConf_Clustering :: Confluence -> Set Module -> Double
sumConf_Clustering c ms = sum $ map (sumConf c) (Set.toList ms)
qualityConf_Clustering :: Confluence -> Set Module -> Double
qualityConf_Clustering c ms = sum ms' -- / (sum $ Set.map (fromIntegral . Set.size) ms)
where
ms' = Set.toList
$ Set.map (\m -> qualityConf_Module c m ) ms
------------------------------------------------------------------------
-- | TODO Modularity
modularity :: (DynGraph gr, Ord a, Serialize a)
=> gr a Double -> Clustering -> Double
modularity g m = sum $ Set.toList $ Set.map (modularityModule g) m
modularityModule :: (Serialize a, Ord a, DynGraph gr)
=> gr a Double -> Module -> Double
modularityModule g ns = subEdges -- (edgeDensity - coverage) / m
where
m = fromIntegral $ length $ edges g
edgeDensity = (sum (Set.map (\node -> degree g node) ns))
coverage = fromIntegral (length $ edges g) / m
coverage' = fromIntegral (length $ edges $ subgraph (Set.toList ns) g) / m
subEdges = sum
$ map (\(n1,n2) -> 1 - ((degree g n1 + degree g n2)/ (2*m)))
$ edges $ subgraph (Set.toList ns) g
modularityIgraph :: (DynGraph gr, Ord a, Serialize a)
=> gr a Double -> Clustering -> Double
modularityIgraph g m = IG.modularity g' Nothing ns
where
g' = IG.fromFGL g
ns = Set.toList (Set.map Set.toList m)
------------------------------------------------------------------------
-- | Scores Type
------------------------------------------------------------------------
data Score = Score { _score_sumConf :: SumConf
, _score_qualityConf :: QualityConf
, _score_modularity :: Double
}
deriving (Show)
makeLenses ''Score
instance HasScore Score (Set Node) where
hasScore g c mod = Score s q m
where
s = sumConf c mod
q = qualityConf_Module c mod
m = modularityModule g mod
updateScore g c (Score s q m) m1 m2 = Score s' q' m'
where
s' = s + (sumConf c $ Set.union m1 m2)
- (sumConf c m1 + sumConf c m2)
q' = q + (qualityConf_Module c $ Set.union m1 m2)
- (qualityConf_Module c m1 + sumConf c m2)
m' = m + (modularityModule g $ Set.union m1 m2)
- (modularityModule g m1 + modularityModule g m2)
instance TestScore Clustering Module where
testScore c mm m1 m2 = q <= q1q2
where
q = qualityConf_Clustering c mm
q1q2 = qualityConf_Clustering c (Set.insert (Set.union m1 m2) $ Set.delete m2 $ Set.delete m1 mm)
testScore' c mm m1 m2 = q < q1q2
where
q = sumConf_Clustering c mm
q1q2 = sumConf_Clustering c (Set.insert (Set.union m1 m2) $ Set.delete m2 $ Set.delete m1 mm)
testScore'' c mm m1 m2 = m1m2 >= m1_m2
where
m1_m2 = qualityConf_Module c m1 + qualityConf_Module c m2
m1m2 = qualityConf_Module c (Set.union m1 m2)
testScore''' c mm m1 m2 = m1m2 >= m1_m2
where
m1_m2 = sumConf c m1 + qualityConf_Module c m2
m1m2 = sumConf c (Set.union m1 m2)
instance HasScore Score Clustering where
hasScore g c ss = -- qualityConf_Clustering c ss
hasScore g c (Set.toList ss)
instance HasScore Score [Set Node] where
hasScore g c ns = foldl' (+) 0 $ map (hasScore g c) ns
instance Num Score where
(+) (Score s1 s2 s3)
(Score s1' s2' s3') =
Score (s1 + s1')
(s2 + s2')
(s3 + s3')
fromInteger _ = Score 0 0 0
instance Monoid Score where
mempty = Score 0 0 0
instance Semigroup Score where
(<>) (Score s1 s2 s3 )
(Score s1' s2' s3') =
Score (s1 <> s1')
(s2 <> s2')
(s3 <> s3')
instance Eq Score where
(==) s1 s2 = (==) (view score_sumConf s1)
(view score_sumConf s2)
instance Ord Score where
compare s1 s2 = if (view score_sumConf s1) > (view score_sumConf s2)
-- && (view score_qualityConf s1) > (view score_qualityConf s2)
then GT
else LT