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, unPrefixSwagger)
  28 import Gargantext.Core.Types (ListId)
  29 import Gargantext.Database.Types.Node (NodeId)
  30 import Gargantext.Prelude
  31 import Test.QuickCheck (elements)
  32 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  33 import qualified Data.Aeson as DA
  34 import qualified Data.Text as T
  35 import qualified Text.Read as T
  36
  37
  38 data TypeNode = Terms | Unknown
  39   deriving (Show, Generic)
  40
  41 $(deriveJSON (unPrefix "") ''TypeNode)
  42 instance ToSchema TypeNode
  43
  44 data Attributes = Attributes { clust_default :: Int }
  45   deriving (Show, Generic)
  46 $(deriveJSON (unPrefix "") ''Attributes)
  47 instance ToSchema Attributes
  48
  49 data Node = Node { node_size  :: Int
  50                  , node_type  :: TypeNode -- TODO NgramsType | Person
  51                  , node_id    :: Text     -- TODO NgramId
  52                  , node_label :: Text
  53                  , node_x_coord :: Double
  54                  , node_y_coord :: Double
  55                  , node_attributes :: Attributes
  56                  }
  57   deriving (Show, Generic)
  58 $(deriveJSON (unPrefix "node_") ''Node)
  59 instance ToSchema Node where
  60   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
  61
  62
  63 data Edge = Edge { edge_source :: Text
  64                  , edge_target :: Text
  65                  , edge_weight :: Double
  66                  , edge_confluence :: Double
  67                  , edge_id     :: Text
  68                  }
  69   deriving (Show, Generic)
  70 $(deriveJSON (unPrefix "edge_") ''Edge)
  71 instance ToSchema Edge where
  72   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
  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 = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
  83
  84 makeLenses ''LegendField
  85 --
  86 data GraphMetadata = GraphMetadata { _gm_title    :: Text   -- title of the graph
  87                                    , _gm_corpusId :: [NodeId]  -- we can map with different corpus
  88                                    , _gm_legend :: [LegendField] -- legend of the Graph
  89                                    , _gm_listId :: ListId
  90                                    }
  91   deriving (Show, Generic)
  92 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
  93 instance ToSchema GraphMetadata where
  94   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
  95 makeLenses ''GraphMetadata
  96
  97
  98 data Graph = Graph { _graph_nodes :: [Node]
  99                    , _graph_edges :: [Edge]
 100                    , _graph_metadata :: Maybe GraphMetadata
 101                    }
 102   deriving (Show, Generic)
 103 $(deriveJSON (unPrefix "_graph_") ''Graph)
 104 makeLenses ''Graph
 105
 106 instance ToSchema Graph where
 107   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
 108
 109 -- | Intances for the mack
 110 instance Arbitrary Graph where
 111   arbitrary = elements $ [defaultGraph]
 112
 113 defaultGraph :: Graph
 114 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}
 115
 116
 117 -----------------------------------------------------------
 118 -- V3 Gargantext Version
 119
 120 data AttributesV3 = AttributesV3 { cl :: Int }
 121   deriving (Show, Generic)
 122 $(deriveJSON (unPrefix "") ''AttributesV3)
 123
 124 data NodeV3 = NodeV3 { no_id :: Int
 125                      , no_at :: AttributesV3
 126                      , no_s  :: Int
 127                      , no_lb :: Text
 128                      }
 129   deriving (Show, Generic)
 130 $(deriveJSON (unPrefix "no_") ''NodeV3)
 131
 132 data EdgeV3 = EdgeV3 { eo_s :: Int
 133                      , eo_t :: Int
 134                      , eo_w :: Text
 135                      }
 136   deriving (Show, Generic)
 137 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
 138
 139 data GraphV3 = GraphV3 { go_links :: [EdgeV3]
 140                        , go_nodes :: [NodeV3]
 141                        }
 142   deriving (Show, Generic)
 143 $(deriveJSON (unPrefix "go_") ''GraphV3)
 144
 145 -----------------------------------------------------------
 146 -----------------------------------------------------------
 147
 148 graphV3ToGraph :: GraphV3 -> Graph
 149 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
 150   where
 151     nodeV32node :: NodeV3 -> Node
 152     nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
 153                 = Node no_s' Terms (cs $ show no_id') no_lb' 0 0 (Attributes cl')
 154
 155     linkV32edge :: Int -> EdgeV3 -> Edge
 156     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)
 157
 158
 159 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
 160 graphV3ToGraphWithFiles g1 g2 = do
 161   -- GraphV3 <- IO Fichier
 162   graph <- DBL.readFile g1
 163   let newGraph = case DA.decode graph :: Maybe GraphV3 of
 164         Nothing -> panic (T.pack "no graph")
 165         Just new -> new
 166
 167   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 168
 169 readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
 170 readGraphFromJson fp = do
 171   graph <- liftIO $ DBL.readFile fp
 172   pure $ DA.decode graph