]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Graph/Tools.hs
[OPTIM] concurrent threads (fix mem leaks)
[gargantext.git] / src / Gargantext / Viz / Graph / Tools.hs
1 {-|
2 Module : Gargantext.Viz.Graph.Tools
3 Description : Tools to build Graph
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 -}
11
12 {-# LANGUAGE NoImplicitPrelude #-}
13 {-# LANGUAGE OverloadedStrings #-}
14
15 module Gargantext.Viz.Graph.Tools
16 where
17
18 import Debug.Trace (trace)
19 import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
20 import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
21 import Data.Map (Map)
22 import qualified Data.Set as Set
23 import Data.Text (Text)
24 import Gargantext.Prelude
25 import Gargantext.Core.Statistics
26 import Gargantext.Viz.Graph
27 import Gargantext.Viz.Graph.Bridgeness (bridgeness)
28 import Gargantext.Viz.Graph.Distances.Matrice (measureConditional)
29 import Gargantext.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map, Index)
30 import Gargantext.Viz.Graph.IGraph (mkGraphUfromEdges)
31 import Gargantext.Viz.Graph.Proxemy (confluence)
32 import GHC.Float (sin, cos)
33 import qualified IGraph as Igraph
34 import qualified IGraph.Algorithms.Layout as Layout
35 import qualified Data.Vector.Storable as Vec
36 import qualified Data.Map as Map
37 import qualified Data.List as List
38
39 type Threshold = Double
40
41
42 cooc2graph' :: Ord t => Double
43 -> Map (t, t) Int
44 -> Map (Index, Index) Double
45 cooc2graph' threshold myCooc = distanceMap
46 where
47 (ti, _) = createIndices myCooc
48 myCooc' = toIndex ti myCooc
49 matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
50 distanceMat = measureConditional matCooc
51 distanceMap = Map.filter (> threshold) $ mat2map distanceMat
52
53
54 cooc2graph :: Threshold
55 -> (Map (Text, Text) Int)
56 -> IO Graph
57 cooc2graph threshold myCooc = do
58 let (ti, _) = createIndices myCooc
59 myCooc' = toIndex ti myCooc
60 matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
61 distanceMat = measureConditional matCooc
62 distanceMap = Map.filter (> threshold) $ mat2map distanceMat
63
64 let nodesApprox :: Int
65 nodesApprox = n'
66 where
67 (as, bs) = List.unzip $ Map.keys distanceMap
68 n' = Set.size $ Set.fromList $ as <> bs
69 ClustersParams rivers level = {-trace ("nodesApprox: " <> show nodesApprox) $-} clustersParams nodesApprox
70
71
72 partitions <- case Map.size distanceMap > 0 of
73 True -> trace ("level" <> show level) $ cLouvain level distanceMap
74 False -> panic "Text.Flow: DistanceMap is empty"
75
76 let bridgeness' = {-trace ("rivers: " <> show rivers) $-}
77 bridgeness rivers partitions distanceMap
78
79 let confluence' = confluence (Map.keys bridgeness') 3 True False
80
81 data2graph (Map.toList ti) myCooc' bridgeness' confluence' partitions
82
83
84 data ClustersParams = ClustersParams { bridgness :: Double
85 , louvain :: Text
86 } deriving (Show)
87
88 clustersParams :: Int -> ClustersParams
89 clustersParams x = ClustersParams (fromIntegral x) "0.00000001" -- y
90 {- where
91 y | x < 100 = "0.000001"
92 | x < 350 = "0.000001"
93 | x < 500 = "0.000001"
94 | x < 1000 = "0.000001"
95 | otherwise = "1"
96 -}
97
98 ----------------------------------------------------------
99 -- | From data to Graph
100 data2graph :: [(Text, Int)]
101 -> Map (Int, Int) Int
102 -> Map (Int, Int) Double
103 -> Map (Int, Int) Double
104 -> [LouvainNode]
105 -> IO Graph
106 data2graph labels coocs bridge conf partitions = do
107
108 let community_id_by_node_id = Map.fromList [ (n, c) | LouvainNode n c <- partitions ]
109
110 nodes <- mapM (setCoord ForceAtlas labels bridge)
111 [ (n, Node { node_size = maybe 0 identity (Map.lookup (n,n) coocs)
112 , node_type = Terms -- or Unknown
113 , node_id = cs (show n)
114 , node_label = l
115 , node_x_coord = 0
116 , node_y_coord = 0
117 , node_attributes =
118 Attributes { clust_default = maybe 0 identity
119 (Map.lookup n community_id_by_node_id) } }
120 )
121 | (l, n) <- labels
122 , Set.member n $ Set.fromList
123 $ List.concat
124 $ map (\((s,t),d) -> if d > 0 && s /=t then [s,t] else [])
125 $ Map.toList bridge
126 ]
127
128 let edges = [ Edge { edge_source = cs (show s)
129 , edge_target = cs (show t)
130 , edge_weight = d
131 , edge_confluence = maybe 0 identity $ Map.lookup (s,t) conf
132 -- , edge_confluence = maybe (panic "E: data2graph edges") identity $ Map.lookup (s,t) conf
133 , edge_id = cs (show i) }
134 | (i, ((s,t), d)) <- zip ([0..]::[Integer]) (Map.toList bridge), s /= t, d > 0
135 ]
136
137 pure $ Graph nodes edges Nothing
138
139 ------------------------------------------------------------------------
140
141 data Layout = KamadaKawai | ACP | ForceAtlas
142
143
144 setCoord' :: (Int -> (Double, Double)) -> (Int, Node) -> Node
145 setCoord' f (i,n) = n { node_x_coord = x, node_y_coord = y }
146 where
147 (x,y) = f i
148
149
150 -- | ACP
151 setCoord :: Ord a => Layout -> [(a, Int)] -> Map (Int, Int) Double -> (Int, Node) -> IO Node
152 setCoord l labels m (n,node) = getCoord l labels m n
153 >>= \(x,y) -> pure $ node { node_x_coord = x
154 , node_y_coord = y
155 }
156
157
158 getCoord :: Ord a => Layout
159 -> [(a, Int)] -> Map (Int, Int) Double -> Int -> IO (Double, Double)
160 getCoord KamadaKawai _ m n = layout m n
161
162 getCoord ForceAtlas _ _ n = pure (sin d, cos d)
163 where
164 d = fromIntegral n
165
166 getCoord ACP labels m n = pure $ to2d $ maybe (panic "Graph.Tools no coordinate") identity
167 $ Map.lookup n
168 $ pcaReduceTo (Dimension 2)
169 $ mapArray labels m
170 where
171 to2d :: Vec.Vector Double -> (Double, Double)
172 to2d v = (x',y')
173 where
174 ds = take 2 $ Vec.toList v
175 x' = head' "to2d" ds
176 y' = last' "to2d" ds
177
178 mapArray :: Ord a => [(a, Int)] -> Map (Int, Int) Double -> Map Int (Vec.Vector Double)
179 mapArray items m' = Map.fromList [ toVec n' ns m' | n' <- ns ]
180 where
181 ns = map snd items
182
183 toVec :: Int -> [Int] -> Map (Int,Int) Double -> (Int, Vec.Vector Double)
184 toVec n' ns' m' = (n', Vec.fromList $ map (\n'' -> maybe 0 identity $ Map.lookup (n',n'') m') ns')
185 ------------------------------------------------------------------------
186
187 -- | KamadaKawai Layout
188 -- TODO TEST: check labels, nodeId and coordinates
189 layout :: Map (Int, Int) Double -> Int -> IO (Double, Double)
190 layout m n = maybe (panic "") identity <$> Map.lookup n <$> coord
191 where
192 coord :: IO (Map Int (Double,Double))
193 coord = Map.fromList <$> List.zip (Igraph.nodes g) <$> (Layout.getLayout g p)
194 --p = Layout.defaultLGL
195 p = Layout.defaultKamadaKawai
196 g = mkGraphUfromEdges $ map fst $ List.filter (\e -> snd e > 0) $ Map.toList m
197