Graph.hs 12.6 KB
Newer Older
1
{-|
2
Module      : Gargantext.Core.Viz.Graph
3
Description : Graph utils
4 5 6 7 8 9 10 11
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

12
{-# OPTIONS_GHC -fno-warn-orphans #-}
13
{-# LANGUAGE TemplateHaskell      #-}
14

15
module Gargantext.Core.Viz.Graph
16 17
  where

18
import Data.ByteString.Lazy as DBL (readFile, writeFile)
19
import Data.HashMap.Strict (HashMap, lookup)
20
import Data.Text (pack)
21
import GHC.IO (FilePath)
Alexandre Delanoë's avatar
Alexandre Delanoë committed
22

23 24 25
import qualified Data.Aeson as DA
import qualified Data.Text as T
import qualified Text.Read as T
26

27
import Gargantext.API.Ngrams.Types (NgramsTerm(..), NgramsRepoElement(..), mSetToList)
28
import Gargantext.Core.Methods.Distances (GraphMetric)
29 30 31 32 33
import Gargantext.Core.Types (ListId)
import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Prelude

34

35 36 37
data TypeNode = Terms | Unknown
  deriving (Show, Generic)

38 39
instance ToJSON TypeNode
instance FromJSON TypeNode
40
instance ToSchema TypeNode
41 42 43 44

data Attributes = Attributes { clust_default :: Int }
  deriving (Show, Generic)
$(deriveJSON (unPrefix "") ''Attributes)
45
instance ToSchema Attributes
46

47
data Node = Node { node_size  :: Int
48 49
                 , node_type  :: TypeNode -- TODO NgramsType | Person
                 , node_id    :: Text     -- TODO NgramId
50
                 , node_label :: Text
51 52
                 , node_x_coord :: Double
                 , node_y_coord :: Double
53
                 , node_attributes :: Attributes
54
                 , node_children :: [Text]
55 56
                 }
  deriving (Show, Generic)
57
$(deriveJSON (unPrefix "node_") ''Node)
58
instance ToSchema Node where
59
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
60

61

62 63 64
data Edge = Edge { edge_source :: Text
                 , edge_target :: Text
                 , edge_weight :: Double
65
                 , edge_confluence :: Double
66
                 , edge_id     :: Text
67 68
                 }
  deriving (Show, Generic)
69

70
$(deriveJSON (unPrefix "edge_") ''Edge)
71

72
instance ToSchema Edge where
73
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
74 75 76 77 78 79 80 81 82

---------------------------------------------------------------
data LegendField = LegendField { _lf_id :: Int
                               , _lf_color :: Text
                               , _lf_label :: Text
   } deriving (Show, Generic)
$(deriveJSON (unPrefix "_lf_") ''LegendField)

instance ToSchema LegendField where
83
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
84 85

makeLenses ''LegendField
86 87
---------------------------------------------------------------
type Version = Int
88 89 90 91
data ListForGraph =
  ListForGraph { _lfg_listId  :: ListId
               , _lfg_version :: Version
               } deriving (Show, Generic)
92 93 94 95 96 97 98
$(deriveJSON (unPrefix "_lfg_") ''ListForGraph)

instance ToSchema ListForGraph where
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")

makeLenses ''ListForGraph

99
--
100
data GraphMetadata =
101 102 103 104 105 106 107
  GraphMetadata { _gm_title            :: Text          -- title of the graph
                , _gm_metric           :: GraphMetric
                , _gm_corpusId         :: [NodeId]      -- we can map with different corpus
                , _gm_legend           :: [LegendField] -- legend of the Graph
                , _gm_list             :: ListForGraph
                , _gm_startForceAtlas  :: Bool
                -- , _gm_version       :: Int
108
                }
109 110 111
  deriving (Show, Generic)
$(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
instance ToSchema GraphMetadata where
112
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
113
makeLenses ''GraphMetadata
114

115

116 117
data Graph = Graph { _graph_nodes    :: [Node]
                   , _graph_edges    :: [Edge]
118
                   , _graph_metadata :: Maybe GraphMetadata
119 120
                   }
  deriving (Show, Generic)
121 122 123 124
$(deriveJSON (unPrefix "_graph_") ''Graph)
makeLenses ''Graph

instance ToSchema Graph where
125
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
126

127
-- | Intances for the mock
128
instance Arbitrary Graph where
129
  arbitrary = elements $ [defaultGraph]
130

131
defaultGraph :: Graph
132
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_children = []},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_children = []},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_children = []},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_children = []},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_children = []},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_children = []},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_children = []},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_children = []},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}, node_children = []}], _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}
133

134

135
-----------------------------------------------------------
136
-- V3 Gargantext Version
137

138
data AttributesV3 = AttributesV3 { cl :: Int }
139
  deriving (Show, Generic)
140
$(deriveJSON (unPrefix "") ''AttributesV3)
141

142
data NodeV3 = NodeV3 { no_id :: Int
143 144 145 146
                     , no_at :: AttributesV3
                     , no_s  :: Int
                     , no_lb :: Text
                     }
147
  deriving (Show, Generic)
148
$(deriveJSON (unPrefix "no_") ''NodeV3)
149

150
data EdgeV3 = EdgeV3 { eo_s :: Int
151 152 153
                     , eo_t :: Int
                     , eo_w :: Text
                     }
154
  deriving (Show, Generic)
155
$(deriveJSON (unPrefix "eo_") ''EdgeV3)
156

157 158 159
data GraphV3 = GraphV3 { go_links :: [EdgeV3]
                       , go_nodes :: [NodeV3]
                       }
160
  deriving (Show, Generic)
161
$(deriveJSON (unPrefix "go_") ''GraphV3)
162

163 164 165 166 167 168 169 170 171 172
-----------------------------------------------------------
data Camera = Camera { _camera_ratio :: Double
                     , _camera_x     :: Double
                     , _camera_y     :: Double }
  deriving (Show, Generic)
$(deriveJSON (unPrefix "_camera_") ''Camera)
makeLenses ''Camera

instance ToSchema Camera where
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_camera_")
173

174
-----------------------------------------------------------
175 176
data HyperdataGraph =
  HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
177
                 , _hyperdataCamera :: !(Maybe Camera)
178
                 } deriving (Show, Generic)
179 180 181
$(deriveJSON (unPrefix "_") ''HyperdataGraph)
instance ToSchema HyperdataGraph where
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
182

183
defaultHyperdataGraph :: HyperdataGraph 
184
defaultHyperdataGraph = HyperdataGraph Nothing Nothing
185 186


187 188 189
instance Hyperdata HyperdataGraph
makeLenses ''HyperdataGraph

Alexandre Delanoë's avatar
Alexandre Delanoë committed
190 191 192 193
instance FromField HyperdataGraph
  where
    fromField = fromField'

194
instance DefaultFromField SqlJsonb HyperdataGraph
Alexandre Delanoë's avatar
Alexandre Delanoë committed
195
  where
196
    defaultFromField = fromPGSFromField
Alexandre Delanoë's avatar
Alexandre Delanoë committed
197

198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
-----------------------------------------------------------
-- This type is used to return graph via API
-- hyperdataGraphAPI field is not a Maybe anymore – graph is always computed
data HyperdataGraphAPI =
  HyperdataGraphAPI { _hyperdataAPIGraph  :: Graph
                    , _hyperdataAPICamera :: !(Maybe Camera)
                    } deriving (Show, Generic)
$(deriveJSON (unPrefix "_hyperdataAPI") ''HyperdataGraphAPI)
instance ToSchema HyperdataGraphAPI where
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hyperdataAPI")

makeLenses ''HyperdataGraphAPI

instance FromField HyperdataGraphAPI
  where
    fromField = fromField'

215
-----------------------------------------------------------
216
graphV3ToGraph :: GraphV3 -> Graph
217 218 219
graphV3ToGraph (GraphV3 links nodes) = Graph { _graph_nodes = map nodeV32node nodes
                                             , _graph_edges = zipWith linkV32edge [1..] links
                                             , _graph_metadata = Nothing }
220
  where
221 222
    nodeV32node :: NodeV3 -> Node
    nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
223 224 225 226 227 228 229
                = Node { node_size = no_s'
                       , node_type = Terms
                       , node_id = cs $ show no_id'
                       , node_label = no_lb'
                       , node_x_coord = 0
                       , node_y_coord = 0
                       , node_attributes = Attributes cl'
230
                       , node_children = [] }
231

232
    linkV32edge :: Int -> EdgeV3 -> Edge
233 234 235 236 237 238
    linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') =
      Edge { edge_source = cs $ show eo_s'
           , edge_target = cs $ show eo_t'
           , edge_weight = (T.read $ T.unpack eo_w') :: Double
           , edge_confluence = 0.5
           , edge_id = cs $ show n }
239 240


241 242 243
graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
graphV3ToGraphWithFiles g1 g2 = do
  -- GraphV3 <- IO Fichier
244
  graph <- DBL.readFile g1
245
  let newGraph = case DA.decode graph :: Maybe GraphV3 of
246
        Nothing -> panic (T.pack "no graph")
247 248
        Just new -> new

249
  DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
250

251
readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
252
readGraphFromJson fp = do
253
  graph <- liftBase $ DBL.readFile fp
254
  pure $ DA.decode graph
255 256 257 258 259 260 261 262 263 264 265 266


-----------------------------------------------------------
mergeGraphNgrams :: Graph -> Maybe (HashMap NgramsTerm NgramsRepoElement) -> Graph
mergeGraphNgrams g Nothing = g
mergeGraphNgrams graph@(Graph { _graph_nodes }) (Just listNgrams) = set graph_nodes newNodes graph
  where
    newNodes = insertChildren <$> _graph_nodes
    insertChildren (Node { node_label, .. }) = Node { node_children = children', .. }
      where
        -- lookup (NgramsTerm node_label) in listNgrams, then fetch (NgramsRepoElement _nre_children)
        children' = case (lookup (NgramsTerm node_label) listNgrams) of
267 268
          Nothing  -> []
          Just (NgramsRepoElement { _nre_children }) -> unNgramsTerm <$> mSetToList _nre_children