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