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 -- | Intances for the mack
  87 instance Arbitrary Graph where
  88   arbitrary = elements $ [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"}]}]
  89
  90
  91 -----------------------------------------------------------
  92 -- Old Gargantext Version
  93
  94 data AttributesOld = AttributesOld { cl :: Int }
  95   deriving (Show, Generic)
  96 $(deriveJSON (unPrefix "") ''AttributesOld)
  97
  98 data NodeOld = NodeOld { no_id :: Int
  99                    , no_at :: AttributesOld
 100                    , no_s :: Int
 101                    , no_lb :: Text
 102                    }
 103   deriving (Show, Generic)
 104 $(deriveJSON (unPrefix "no_") ''NodeOld)
 105
 106 data EdgeOld = EdgeOld { eo_s :: Int
 107                  , eo_t :: Int
 108                  , eo_w :: Text
 109                  }
 110   deriving (Show, Generic)
 111 $(deriveJSON (unPrefix "eo_") ''EdgeOld)
 112
 113 data GraphOld = GraphOld {
 114                            go_links :: [EdgeOld]
 115                          , go_nodes :: [NodeOld]
 116                    }
 117   deriving (Show, Generic)
 118 $(deriveJSON (unPrefix "go_") ''GraphOld)
 119
 120 ----------------------------------------------------------
 121 -- | From data to Graph
 122 -- FIXME: distance should not be a map since we just "toList" it (same as cLouvain)
 123 data2graph :: [(Label, Int)] -> Map (Int, Int) Int
 124                              -> Map (Int, Int) Double
 125                              -> [LouvainNode]
 126               -> Graph
 127 data2graph labels coocs distance partitions = Graph nodes edges
 128   where
 129     community_id_by_node_id = M.fromList [ (n, c) | LouvainNode n c <- partitions ]
 130     nodes = [ Node { node_size = maybe 0 identity (M.lookup (n,n) coocs)
 131                    , node_type = Terms -- or Unknown
 132                    , node_id = cs (show n)
 133                    , node_label = T.unwords l
 134                    , node_attributes =
 135                      Attributes { clust_default = maybe 0 identity
 136                                 (M.lookup n community_id_by_node_id) } }
 137             | (l, n) <- labels ]
 138     edges = [ Edge { edge_source = cs (show s)
 139                    , edge_target = cs (show t)
 140                    , edge_weight = w
 141                    , edge_id     = cs (show i) }
 142             | (i, ((s,t), w)) <- zip ([0..]::[Integer]) (M.toList distance) ]
 143 -----------------------------------------------------------
 144 -----------------------------------------------------------
 145
 146 graphOld2graph :: GraphOld -> Graph
 147 graphOld2graph (GraphOld links nodes) = Graph (map nodeOld2node nodes) (zipWith linkOld2edge [1..] links)
 148   where
 149     nodeOld2node :: NodeOld -> Node
 150     nodeOld2node (NodeOld no_id' (AttributesOld cl') no_s' no_lb')
 151                 = Node no_s' Terms (cs $ show no_id') no_lb' (Attributes cl')
 152
 153     linkOld2edge :: Int -> EdgeOld -> Edge
 154     linkOld2edge n (EdgeOld 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)
 155
 156
 157 graphOld2graphWithFiles :: FilePath -> FilePath -> IO ()
 158 graphOld2graphWithFiles g1 g2 = do
 159   -- GraphOld <- IO Fichier
 160   graph <- DBL.readFile g1
 161   let newGraph = case DA.decode graph :: Maybe GraphOld of
 162         Nothing -> panic (T.pack "no graph")
 163         Just new -> new
 164
 165   DBL.writeFile g2 (DA.encode $ graphOld2graph newGraph)
 166
 167