]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Graph.hs
changement du seuil
[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 type Version = Int
88 data ListForGraph = 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 = GraphMetadata { _gm_title :: Text -- title of the graph
100 , _gm_corpusId :: [NodeId] -- we can map with different corpus
101 , _gm_legend :: [LegendField] -- legend of the Graph
102 , _gm_list :: ListForGraph
103 -- , _gm_version :: Int
104 }
105 deriving (Show, Generic)
106 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
107 instance ToSchema GraphMetadata where
108 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
109 makeLenses ''GraphMetadata
110
111
112 data Graph = Graph { _graph_nodes :: [Node]
113 , _graph_edges :: [Edge]
114 , _graph_metadata :: Maybe GraphMetadata
115 }
116 deriving (Show, Generic)
117 $(deriveJSON (unPrefix "_graph_") ''Graph)
118 makeLenses ''Graph
119
120 instance ToSchema Graph where
121 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
122
123 -- | Intances for the mack
124 instance Arbitrary Graph where
125 arbitrary = elements $ [defaultGraph]
126
127 defaultGraph :: Graph
128 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}
129
130
131 -----------------------------------------------------------
132 -- V3 Gargantext Version
133
134 data AttributesV3 = AttributesV3 { cl :: Int }
135 deriving (Show, Generic)
136 $(deriveJSON (unPrefix "") ''AttributesV3)
137
138 data NodeV3 = NodeV3 { no_id :: Int
139 , no_at :: AttributesV3
140 , no_s :: Int
141 , no_lb :: Text
142 }
143 deriving (Show, Generic)
144 $(deriveJSON (unPrefix "no_") ''NodeV3)
145
146 data EdgeV3 = EdgeV3 { eo_s :: Int
147 , eo_t :: Int
148 , eo_w :: Text
149 }
150 deriving (Show, Generic)
151 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
152
153 data GraphV3 = GraphV3 { go_links :: [EdgeV3]
154 , go_nodes :: [NodeV3]
155 }
156 deriving (Show, Generic)
157 $(deriveJSON (unPrefix "go_") ''GraphV3)
158
159 -----------------------------------------------------------
160
161 data HyperdataGraph = HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
162 } deriving (Show, Generic)
163 $(deriveJSON (unPrefix "") ''HyperdataGraph)
164
165 instance Hyperdata HyperdataGraph
166 makeLenses ''HyperdataGraph
167
168
169 -----------------------------------------------------------
170
171 graphV3ToGraph :: GraphV3 -> Graph
172 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
173 where
174 nodeV32node :: NodeV3 -> Node
175 nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
176 = Node no_s' Terms (cs $ show no_id') no_lb' 0 0 (Attributes cl')
177
178 linkV32edge :: Int -> EdgeV3 -> Edge
179 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)
180
181
182 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
183 graphV3ToGraphWithFiles g1 g2 = do
184 -- GraphV3 <- IO Fichier
185 graph <- DBL.readFile g1
186 let newGraph = case DA.decode graph :: Maybe GraphV3 of
187 Nothing -> panic (T.pack "no graph")
188 Just new -> new
189
190 DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
191
192 readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
193 readGraphFromJson fp = do
194 graph <- liftIO $ DBL.readFile fp
195 pure $ DA.decode graph