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
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
14 {-# LANGUAGE DeriveGeneric #-}
15 {-# LANGUAGE FlexibleContexts #-}
16 {-# LANGUAGE MultiParamTypeClasses #-}
17 {-# LANGUAGE NoImplicitPrelude #-}
18 {-# LANGUAGE TemplateHaskell #-}
20 module Gargantext.Viz.Graph
23 import Control.Lens (makeLenses)
24 import Data.Aeson.TH (deriveJSON)
25 import Data.ByteString.Lazy as DBL (readFile, writeFile)
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
44 data TypeNode = Terms | Unknown
45 deriving (Show, Generic)
47 $(deriveJSON (unPrefix "") ''TypeNode)
48 instance ToSchema TypeNode
50 data Attributes = Attributes { clust_default :: Int }
51 deriving (Show, Generic)
52 $(deriveJSON (unPrefix "") ''Attributes)
53 instance ToSchema Attributes
55 data Node = Node { node_size :: Int
56 , node_type :: TypeNode -- TODO NgramsType | Person
57 , node_id :: Text -- TODO NgramId
59 , node_x_coord :: Double
60 , node_y_coord :: Double
61 , node_attributes :: Attributes
63 deriving (Show, Generic)
64 $(deriveJSON (unPrefix "node_") ''Node)
65 instance ToSchema Node where
66 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
69 data Edge = Edge { edge_source :: Text
71 , edge_weight :: Double
72 , edge_confluence :: Double
75 deriving (Show, Generic)
76 $(deriveJSON (unPrefix "edge_") ''Edge)
77 instance ToSchema Edge where
78 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
80 ---------------------------------------------------------------
81 data LegendField = LegendField { _lf_id :: Int
84 } deriving (Show, Generic)
85 $(deriveJSON (unPrefix "_lf_") ''LegendField)
87 instance ToSchema LegendField where
88 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
90 makeLenses ''LegendField
91 ---------------------------------------------------------------
93 data ListForGraph = ListForGraph { _lfg_listId :: ListId
94 , _lfg_version :: Version
95 } deriving (Show, Generic)
96 $(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
98 instance ToSchema ListForGraph where
99 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
101 makeLenses ''ListForGraph
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
110 deriving (Show, Generic)
111 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
112 instance ToSchema GraphMetadata where
113 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
114 makeLenses ''GraphMetadata
117 data Graph = Graph { _graph_nodes :: [Node]
118 , _graph_edges :: [Edge]
119 , _graph_metadata :: Maybe GraphMetadata
121 deriving (Show, Generic)
122 $(deriveJSON (unPrefix "_graph_") ''Graph)
125 instance ToSchema Graph where
126 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
128 -- | Intances for the mack
129 instance Arbitrary Graph where
130 arbitrary = elements $ [defaultGraph]
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}
136 -----------------------------------------------------------
137 -- V3 Gargantext Version
139 data AttributesV3 = AttributesV3 { cl :: Int }
140 deriving (Show, Generic)
141 $(deriveJSON (unPrefix "") ''AttributesV3)
143 data NodeV3 = NodeV3 { no_id :: Int
144 , no_at :: AttributesV3
148 deriving (Show, Generic)
149 $(deriveJSON (unPrefix "no_") ''NodeV3)
151 data EdgeV3 = EdgeV3 { eo_s :: Int
155 deriving (Show, Generic)
156 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
158 data GraphV3 = GraphV3 { go_links :: [EdgeV3]
159 , go_nodes :: [NodeV3]
161 deriving (Show, Generic)
162 $(deriveJSON (unPrefix "go_") ''GraphV3)
164 -----------------------------------------------------------
166 data HyperdataGraph = HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
167 } deriving (Show, Generic)
168 $(deriveJSON (unPrefix "") ''HyperdataGraph)
170 instance Hyperdata HyperdataGraph
171 makeLenses ''HyperdataGraph
173 instance FromField HyperdataGraph
175 fromField = fromField'
177 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
179 queryRunnerColumnDefault = fieldQueryRunnerColumn
182 -----------------------------------------------------------
184 graphV3ToGraph :: GraphV3 -> Graph
185 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
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')
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)
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")
203 DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
205 readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
206 readGraphFromJson fp = do
207 graph <- liftBase $ DBL.readFile fp
208 pure $ DA.decode graph