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