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 ------------------------------------------------------------------------
  20 import GHC.IO (FilePath)
  21 import GHC.Generics (Generic)
  22 import Data.Aeson.TH (deriveJSON)
  23 import qualified Data.Aeson as DA
  24
  25 import Data.ByteString.Lazy as DBL (readFile, writeFile)
  26
  27 import Data.Text (Text, pack)
  28 import qualified Text.Read as T
  29 import qualified Data.Text as T
  30
  31 import Data.Map.Strict (Map)
  32 import qualified Data.Map.Strict as M
  33
  34 import Data.Swagger (ToSchema)
  35
  36 import Gargantext.Prelude
  37 import Gargantext.Core.Types (Label)
  38 import Gargantext.Core.Utils.Prefix (unPrefix)
  39
  40 import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
  41
  42 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  43 import Test.QuickCheck (elements)
  44
  45 ------------------------------------------------------------------------
  46
  47 data TypeNode = Terms | Unknown
  48   deriving (Show, Generic)
  49
  50 $(deriveJSON (unPrefix "") ''TypeNode)
  51
  52 data Attributes = Attributes { clust_default :: Int }
  53   deriving (Show, Generic)
  54 $(deriveJSON (unPrefix "") ''Attributes)
  55
  56 data Node = Node { node_size  :: Int
  57                  , node_type  :: TypeNode
  58                  , node_id    :: Text
  59                  , node_label :: Text
  60                  , node_attributes :: Attributes
  61                  }
  62   deriving (Show, Generic)
  63 $(deriveJSON (unPrefix "node_") ''Node)
  64
  65 data Edge = Edge { edge_source :: Text
  66                  , edge_target :: Text
  67                  , edge_weight :: Double
  68                  , edge_id     :: Text
  69                  }
  70   deriving (Show, Generic)
  71 $(deriveJSON (unPrefix "edge_") ''Edge)
  72
  73 data Graph = Graph { graph_nodes :: [Node]
  74                    , graph_edges :: [Edge]
  75                    }
  76   deriving (Show, Generic)
  77 $(deriveJSON (unPrefix "graph_") ''Graph)
  78
  79 -- | Intances for Swagger documentation
  80 instance ToSchema Node
  81 instance ToSchema TypeNode
  82 instance ToSchema Attributes
  83 instance ToSchema Edge
  84 instance ToSchema Graph
  85
  86 defaultGraph :: Graph
  87 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"}]}
  88
  89 -- | Intances for the mack
  90 instance Arbitrary Graph where
  91   arbitrary = elements $ [defaultGraph]
  92
  93
  94 -----------------------------------------------------------
  95 -- V3 Gargantext Version
  96
  97 data AttributesV3 = AttributesV3 { cl :: Int }
  98   deriving (Show, Generic)
  99 $(deriveJSON (unPrefix "") ''AttributesV3)
 100
 101 data NodeV3 = NodeV3 { no_id :: Int
 102                    , no_at :: AttributesV3
 103                    , no_s :: Int
 104                    , no_lb :: Text
 105                    }
 106   deriving (Show, Generic)
 107 $(deriveJSON (unPrefix "no_") ''NodeV3)
 108
 109 data EdgeV3 = EdgeV3 { eo_s :: Int
 110                  , eo_t :: Int
 111                  , eo_w :: Text
 112                  }
 113   deriving (Show, Generic)
 114 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
 115
 116 data GraphV3 = GraphV3 {
 117                            go_links :: [EdgeV3]
 118                          , go_nodes :: [NodeV3]
 119                    }
 120   deriving (Show, Generic)
 121 $(deriveJSON (unPrefix "go_") ''GraphV3)
 122
 123 ----------------------------------------------------------
 124 -- | From data to Graph
 125 -- FIXME: distance should not be a map since we just "toList" it (same as cLouvain)
 126 data2graph :: [(Label, Int)] -> Map (Int, Int) Int
 127                              -> Map (Int, Int) Double
 128                              -> [LouvainNode]
 129               -> Graph
 130 data2graph labels coocs distance partitions = Graph nodes edges
 131   where
 132     community_id_by_node_id = M.fromList [ (n, c) | LouvainNode n c <- partitions ]
 133     nodes = [ Node { node_size = maybe 0 identity (M.lookup (n,n) coocs)
 134                    , node_type = Terms -- or Unknown
 135                    , node_id = cs (show n)
 136                    , node_label = T.unwords l
 137                    , node_attributes =
 138                      Attributes { clust_default = maybe 0 identity
 139                                 (M.lookup n community_id_by_node_id) } }
 140             | (l, n) <- labels ]
 141     edges = [ Edge { edge_source = cs (show s)
 142                    , edge_target = cs (show t)
 143                    , edge_weight = w
 144                    , edge_id     = cs (show i) }
 145             | (i, ((s,t), w)) <- zip ([0..]::[Integer]) (M.toList distance) ]
 146 -----------------------------------------------------------
 147 -----------------------------------------------------------
 148
 149 graphV3ToGraph :: GraphV3 -> Graph
 150 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links)
 151   where
 152     nodeV32node :: NodeV3 -> Node
 153     nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
 154                 = Node no_s' Terms (cs $ show no_id') no_lb' (Attributes cl')
 155
 156     linkV32edge :: Int -> EdgeV3 -> Edge
 157     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)
 158
 159
 160 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
 161 graphV3ToGraphWithFiles g1 g2 = do
 162   -- GraphV3 <- IO Fichier
 163   graph <- DBL.readFile g1
 164   let newGraph = case DA.decode graph :: Maybe GraphV3 of
 165         Nothing -> panic (T.pack "no graph")
 166         Just new -> new
 167
 168   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 169
 170 readGraphFromJson :: FilePath -> IO (Maybe Graph)
 171 readGraphFromJson fp = do
 172   graph <- DBL.readFile fp
 173   pure $ DA.decode graph