]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Graph.hs
[MERGE] master and masterAfterDemo.
[gargantext.git] / src / Gargantext / Viz / Graph.hs
1 {-|
2 Module : Gargantext.Viz.Graph
3 Description : Graph utils
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 TemplateHaskell #-}
14 {-# LANGUAGE DeriveGeneric #-}
15
16 module Gargantext.Viz.Graph
17 where
18
19 ------------------------------------------------------------------------
20 import Control.Lens (makeLenses)
21 import Control.Monad.IO.Class (MonadIO(liftIO))
22 import GHC.IO (FilePath)
23 import GHC.Generics (Generic)
24 import Data.Aeson.TH (deriveJSON)
25 import qualified Data.Aeson as DA
26
27 import Data.ByteString.Lazy as DBL (readFile, writeFile)
28
29 import Data.Text (Text, pack)
30 import qualified Text.Read as T
31 import qualified Data.Text as T
32
33 import Data.Map.Strict (Map)
34 import qualified Data.Map.Strict as M
35
36 import Data.Swagger
37
38 import Gargantext.Prelude
39 import Gargantext.Core.Types (Label)
40 import Gargantext.Core.Utils.Prefix (unPrefix)
41
42 import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
43
44 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
45 import Test.QuickCheck (elements)
46
47 ------------------------------------------------------------------------
48
49 data TypeNode = Terms | Unknown
50 deriving (Show, Generic)
51
52 $(deriveJSON (unPrefix "") ''TypeNode)
53 instance ToSchema TypeNode
54
55 data Attributes = Attributes { clust_default :: Int }
56 deriving (Show, Generic)
57 $(deriveJSON (unPrefix "") ''Attributes)
58 instance ToSchema Attributes
59
60 data Node = Node { node_size :: Int
61 , node_type :: TypeNode
62 , node_id :: Text
63 , node_label :: Text
64 , node_attributes :: Attributes
65 }
66 deriving (Show, Generic)
67 $(deriveJSON (unPrefix "node_") ''Node)
68 instance ToSchema Node where
69 declareNamedSchema =
70 genericDeclareNamedSchema
71 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
72
73
74 data Edge = Edge { edge_source :: Text
75 , edge_target :: Text
76 , edge_weight :: Double
77 , edge_id :: Text
78 }
79 deriving (Show, Generic)
80 $(deriveJSON (unPrefix "edge_") ''Edge)
81 instance ToSchema Edge where
82 declareNamedSchema =
83 genericDeclareNamedSchema
84 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
85
86 ---------------------------------------------------------------
87 data LegendField = LegendField { _lf_id :: Int
88 , _lf_color :: Text
89 , _lf_label :: Text
90 } deriving (Show, Generic)
91 $(deriveJSON (unPrefix "_lf_") ''LegendField)
92
93 instance ToSchema LegendField where
94 declareNamedSchema =
95 genericDeclareNamedSchema
96 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
97
98 makeLenses ''LegendField
99 --
100 data GraphMetadata = GraphMetadata { _gm_title :: Text -- title of the graph
101 , _gm_corpusId :: [Int] -- we can map with different corpus
102 , _gm_legend :: [LegendField] -- legend of the Graph
103 }
104 deriving (Show, Generic)
105 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
106 instance ToSchema GraphMetadata where
107 declareNamedSchema =
108 genericDeclareNamedSchema
109 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
110 makeLenses ''GraphMetadata
111
112
113 data Graph = Graph { _graph_nodes :: [Node]
114 , _graph_edges :: [Edge]
115 , _graph_metadata :: Maybe GraphMetadata
116 }
117 deriving (Show, Generic)
118 $(deriveJSON (unPrefix "_graph_") ''Graph)
119 makeLenses ''Graph
120
121 instance ToSchema Graph where
122 declareNamedSchema =
123 genericDeclareNamedSchema
124 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 7 fieldLabel}
125
126
127 defaultGraph :: Graph
128 defaultGraph = Graph {_graph_nodes = [Node {node_size = 4, node_type = Terms, node_id = pack "0", node_label = pack "animal", node_attributes = Attributes {clust_default = 0}},Node {node_size = 3, node_type = Terms, node_id = pack "1", node_label = pack "bird", node_attributes = Attributes {clust_default = 0}},Node {node_size = 2, node_type = Terms, node_id = pack "2", node_label = pack "boy", node_attributes = Attributes {clust_default = 1}},Node {node_size = 2, node_type = Terms, node_id = pack "3", node_label = pack "dog", node_attributes = Attributes {clust_default = 0}},Node {node_size = 2, node_type = Terms, node_id = pack "4", node_label = pack "girl", node_attributes = Attributes {clust_default = 1}},Node {node_size = 4, node_type = Terms, node_id = pack "5", node_label = pack "human body", node_attributes = Attributes {clust_default = 1}},Node {node_size = 3, node_type = Terms, node_id = pack "6", node_label = pack "object", node_attributes = Attributes {clust_default = 2}},Node {node_size = 2, node_type = Terms, node_id = pack "7", node_label = pack "pen", node_attributes = Attributes {clust_default = 2}},Node {node_size = 2, node_type = Terms, node_id = pack "8", node_label = pack "table", node_attributes = Attributes {clust_default = 2}}], _graph_edges = [Edge {edge_source = pack "0", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "0"},Edge {edge_source = pack "1", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "1"},Edge {edge_source = pack "1", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "2"},Edge {edge_source = pack "2", edge_target = pack "2", edge_weight = 1.0, edge_id = pack "3"},Edge {edge_source = pack "2", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "4"},Edge {edge_source = pack "3", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "5"},Edge {edge_source = pack "3", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "6"},Edge {edge_source = pack "3", edge_target = pack "3", edge_weight = 1.0, edge_id = pack "7"},Edge {edge_source = pack "4", edge_target = pack "4", edge_weight = 1.0, edge_id = pack "8"},Edge {edge_source = pack "4", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "9"},Edge {edge_source = pack "5", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "10"},Edge {edge_source = pack "6", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "11"},Edge {edge_source = pack "7", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "12"},Edge {edge_source = pack "7", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "13"},Edge {edge_source = pack "8", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "14"},Edge {edge_source = pack "8", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "15"},Edge {edge_source = pack "8", edge_target = pack "8", edge_weight = 1.0, edge_id = pack "16"}], _graph_metadata = Nothing}
129
130 -- | Intances for the mack
131 instance Arbitrary Graph where
132 arbitrary = elements $ [defaultGraph]
133
134
135 -----------------------------------------------------------
136 -- V3 Gargantext Version
137
138 data AttributesV3 = AttributesV3 { cl :: Int }
139 deriving (Show, Generic)
140 $(deriveJSON (unPrefix "") ''AttributesV3)
141
142 data NodeV3 = NodeV3 { no_id :: Int
143 , no_at :: AttributesV3
144 , no_s :: Int
145 , no_lb :: Text
146 }
147 deriving (Show, Generic)
148 $(deriveJSON (unPrefix "no_") ''NodeV3)
149
150 data EdgeV3 = EdgeV3 { eo_s :: Int
151 , eo_t :: Int
152 , eo_w :: Text
153 }
154 deriving (Show, Generic)
155 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
156
157 data GraphV3 = GraphV3 {
158 go_links :: [EdgeV3]
159 , go_nodes :: [NodeV3]
160 }
161 deriving (Show, Generic)
162 $(deriveJSON (unPrefix "go_") ''GraphV3)
163
164 ----------------------------------------------------------
165 -- | From data to Graph
166 -- FIXME: distance should not be a map since we just "toList" it (same as cLouvain)
167 data2graph :: [(Label, Int)] -> Map (Int, Int) Int
168 -> Map (Int, Int) Double
169 -> [LouvainNode]
170 -> Graph
171 data2graph labels coocs distance partitions = Graph nodes edges Nothing
172 where
173 community_id_by_node_id = M.fromList [ (n, c) | LouvainNode n c <- partitions ]
174 nodes = [ Node { node_size = maybe 0 identity (M.lookup (n,n) coocs)
175 , node_type = Terms -- or Unknown
176 , node_id = cs (show n)
177 , node_label = T.unwords l
178 , node_attributes =
179 Attributes { clust_default = maybe 0 identity
180 (M.lookup n community_id_by_node_id) } }
181 | (l, n) <- labels ]
182 edges = [ Edge { edge_source = cs (show s)
183 , edge_target = cs (show t)
184 , edge_weight = w
185 , edge_id = cs (show i) }
186 | (i, ((s,t), w)) <- zip ([0..]::[Integer]) (M.toList distance) ]
187 -----------------------------------------------------------
188 -----------------------------------------------------------
189
190 graphV3ToGraph :: GraphV3 -> Graph
191 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
192 where
193 nodeV32node :: NodeV3 -> Node
194 nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
195 = Node no_s' Terms (cs $ show no_id') no_lb' (Attributes cl')
196
197 linkV32edge :: Int -> EdgeV3 -> Edge
198 linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') = Edge (cs $ show eo_s') (cs $ show eo_t') ((T.read $ T.unpack eo_w') :: Double) (cs $ show n)
199
200
201 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
202 graphV3ToGraphWithFiles g1 g2 = do
203 -- GraphV3 <- IO Fichier
204 graph <- DBL.readFile g1
205 let newGraph = case DA.decode graph :: Maybe GraphV3 of
206 Nothing -> panic (T.pack "no graph")
207 Just new -> new
208
209 DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
210
211 readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
212 readGraphFromJson fp = do
213 graph <- liftIO $ DBL.readFile fp
214 pure $ DA.decode graph