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