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