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