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