]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Graph.hs
Merge branch 'dev' into dev-doc-annotation-issue
[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 {-# OPTIONS_GHC -fno-warn-orphans #-}
13
14 {-# LANGUAGE TemplateHaskell #-}
15
16 module Gargantext.Viz.Graph
17 where
18
19 import Control.Lens (makeLenses)
20 import Data.ByteString.Lazy as DBL (readFile, writeFile)
21 import Data.Text (Text, pack)
22 import GHC.IO (FilePath)
23 import Gargantext.Core.Types (ListId)
24 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
25 import Gargantext.Database.Admin.Types.Node (NodeId)
26 import Gargantext.Viz.Graph.Distances (GraphMetric)
27 import Gargantext.Prelude
28 import Test.QuickCheck (elements)
29 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
30 import qualified Data.Aeson as DA
31 import qualified Data.Text as T
32 import qualified Text.Read as T
33
34
35 data TypeNode = Terms | Unknown
36 deriving (Show, Generic)
37
38 instance ToJSON TypeNode
39 instance FromJSON TypeNode
40 instance ToSchema TypeNode
41
42 data Attributes = Attributes { clust_default :: Int }
43 deriving (Show, Generic)
44 $(deriveJSON (unPrefix "") ''Attributes)
45 instance ToSchema Attributes
46
47 data Node = Node { node_size :: Int
48 , node_type :: TypeNode -- TODO NgramsType | Person
49 , node_id :: Text -- TODO NgramId
50 , node_label :: Text
51 , node_x_coord :: Double
52 , node_y_coord :: Double
53 , node_attributes :: Attributes
54 }
55 deriving (Show, Generic)
56 $(deriveJSON (unPrefix "node_") ''Node)
57 instance ToSchema Node where
58 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
59
60
61 data Edge = Edge { edge_source :: Text
62 , edge_target :: Text
63 , edge_weight :: Double
64 , edge_confluence :: Double
65 , edge_id :: Text
66 }
67 deriving (Show, Generic)
68
69 $(deriveJSON (unPrefix "edge_") ''Edge)
70
71 instance ToSchema Edge where
72 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
73
74 ---------------------------------------------------------------
75 data LegendField = LegendField { _lf_id :: Int
76 , _lf_color :: Text
77 , _lf_label :: Text
78 } deriving (Show, Generic)
79 $(deriveJSON (unPrefix "_lf_") ''LegendField)
80
81 instance ToSchema LegendField where
82 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
83
84 makeLenses ''LegendField
85 ---------------------------------------------------------------
86 type Version = Int
87 data ListForGraph =
88 ListForGraph { _lfg_listId :: ListId
89 , _lfg_version :: Version
90 } deriving (Show, Generic)
91 $(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
92
93 instance ToSchema ListForGraph where
94 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
95
96 makeLenses ''ListForGraph
97
98 --
99 data GraphMetadata =
100 GraphMetadata { _gm_title :: Text -- title of the graph
101 , _gm_metric :: GraphMetric
102 , _gm_corpusId :: [NodeId] -- we can map with different corpus
103 , _gm_legend :: [LegendField] -- legend of the Graph
104 , _gm_list :: ListForGraph
105 -- , _gm_version :: Int
106 }
107 deriving (Show, Generic)
108 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
109 instance ToSchema GraphMetadata where
110 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
111 makeLenses ''GraphMetadata
112
113
114 data Graph = Graph { _graph_nodes :: [Node]
115 , _graph_edges :: [Edge]
116 , _graph_metadata :: Maybe GraphMetadata
117 }
118 deriving (Show, Generic)
119 $(deriveJSON (unPrefix "_graph_") ''Graph)
120 makeLenses ''Graph
121
122 instance ToSchema Graph where
123 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
124
125 -- | Intances for the mack
126 instance Arbitrary Graph where
127 arbitrary = elements $ [defaultGraph]
128
129 defaultGraph :: Graph
130 defaultGraph = Graph {_graph_nodes = [Node {node_x_coord=0, node_y_coord=0, node_size = 4, node_type = Terms, node_id = pack "0", node_label = pack "animal", node_attributes = Attributes {clust_default = 0}},Node {node_x_coord=0, node_y_coord=0, node_size = 3, node_type = Terms, node_id = pack "1", node_label = pack "bird", node_attributes = Attributes {clust_default = 0}},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = Terms, node_id = pack "2", node_label = pack "boy", node_attributes = Attributes {clust_default = 1}},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = Terms, node_id = pack "3", node_label = pack "dog", node_attributes = Attributes {clust_default = 0}},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = Terms, node_id = pack "4", node_label = pack "girl", node_attributes = Attributes {clust_default = 1}},Node {node_x_coord=0, node_y_coord=0, node_size = 4, node_type = Terms, node_id = pack "5", node_label = pack "human body", node_attributes = Attributes {clust_default = 1}},Node {node_x_coord=0, node_y_coord=0, node_size = 3, node_type = Terms, node_id = pack "6", node_label = pack "object", node_attributes = Attributes {clust_default = 2}},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = Terms, node_id = pack "7", node_label = pack "pen", node_attributes = Attributes {clust_default = 2}},Node {node_x_coord=0, node_y_coord=0, 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_confluence=0.5, edge_id = pack "0"},Edge {edge_source = pack "1", edge_target = pack "0", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "1"},Edge {edge_source = pack "1", edge_target = pack "1", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "2"},Edge {edge_source = pack "2", edge_target = pack "2", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "3"},Edge {edge_source = pack "2", edge_target = pack "5", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "4"},Edge {edge_source = pack "3", edge_target = pack "0", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "5"},Edge {edge_source = pack "3", edge_target = pack "1", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "6"},Edge {edge_source = pack "3", edge_target = pack "3", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "7"},Edge {edge_source = pack "4", edge_target = pack "4", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "8"},Edge {edge_source = pack "4", edge_target = pack "5", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "9"},Edge {edge_source = pack "5", edge_target = pack "5", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "10"},Edge {edge_source = pack "6", edge_target = pack "6", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "11"},Edge {edge_source = pack "7", edge_target = pack "6", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "12"},Edge {edge_source = pack "7", edge_target = pack "7", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "13"},Edge {edge_source = pack "8", edge_target = pack "6", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "14"},Edge {edge_source = pack "8", edge_target = pack "7", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "15"},Edge {edge_source = pack "8", edge_target = pack "8", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "16"}], _graph_metadata = Nothing}
131
132
133 -----------------------------------------------------------
134 -- V3 Gargantext Version
135
136 data AttributesV3 = AttributesV3 { cl :: Int }
137 deriving (Show, Generic)
138 $(deriveJSON (unPrefix "") ''AttributesV3)
139
140 data NodeV3 = NodeV3 { no_id :: Int
141 , no_at :: AttributesV3
142 , no_s :: Int
143 , no_lb :: Text
144 }
145 deriving (Show, Generic)
146 $(deriveJSON (unPrefix "no_") ''NodeV3)
147
148 data EdgeV3 = EdgeV3 { eo_s :: Int
149 , eo_t :: Int
150 , eo_w :: Text
151 }
152 deriving (Show, Generic)
153 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
154
155 data GraphV3 = GraphV3 { go_links :: [EdgeV3]
156 , go_nodes :: [NodeV3]
157 }
158 deriving (Show, Generic)
159 $(deriveJSON (unPrefix "go_") ''GraphV3)
160
161
162 -----------------------------------------------------------
163 data HyperdataGraph =
164 HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
165 } deriving (Show, Generic)
166 $(deriveJSON (unPrefix "") ''HyperdataGraph)
167
168 defaultHyperdataGraph :: HyperdataGraph
169 defaultHyperdataGraph = HyperdataGraph Nothing
170
171
172 instance Hyperdata HyperdataGraph
173 makeLenses ''HyperdataGraph
174
175 instance FromField HyperdataGraph
176 where
177 fromField = fromField'
178
179 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
180 where
181 queryRunnerColumnDefault = fieldQueryRunnerColumn
182
183 -----------------------------------------------------------
184 graphV3ToGraph :: GraphV3 -> Graph
185 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
186 where
187 nodeV32node :: NodeV3 -> Node
188 nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
189 = Node no_s' Terms (cs $ show no_id') no_lb' 0 0 (Attributes cl')
190
191 linkV32edge :: Int -> EdgeV3 -> Edge
192 linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') = Edge (cs $ show eo_s')
193 (cs $ show eo_t')
194 ((T.read $ T.unpack eo_w') :: Double)
195 0.5
196 (cs $ show n)
197
198
199 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
200 graphV3ToGraphWithFiles g1 g2 = do
201 -- GraphV3 <- IO Fichier
202 graph <- DBL.readFile g1
203 let newGraph = case DA.decode graph :: Maybe GraphV3 of
204 Nothing -> panic (T.pack "no graph")
205 Just new -> new
206
207 DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
208
209 readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
210 readGraphFromJson fp = do
211 graph <- liftBase $ DBL.readFile fp
212 pure $ DA.decode graph