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
  42 import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
  43
  44 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  45 import Test.QuickCheck (elements)
  46
  47 ------------------------------------------------------------------------
  48
  49 data TypeNode = Terms | Unknown
  50   deriving (Show, Generic)
  51
  52 $(deriveJSON (unPrefix "") ''TypeNode)
  53 instance ToSchema TypeNode
  54
  55 data Attributes = Attributes { clust_default :: Int }
  56   deriving (Show, Generic)
  57 $(deriveJSON (unPrefix "") ''Attributes)
  58 instance ToSchema Attributes
  59
  60 data Node = Node { node_size  :: Int
  61                  , node_type  :: TypeNode
  62                  , node_id    :: Text
  63                  , node_label :: Text
  64                  , node_attributes :: Attributes
  65                  }
  66   deriving (Show, Generic)
  67 $(deriveJSON (unPrefix "node_") ''Node)
  68 instance ToSchema Node where
  69   declareNamedSchema =
  70     genericDeclareNamedSchema
  71       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
  72
  73
  74 data Edge = Edge { edge_source :: Text
  75                  , edge_target :: Text
  76                  , edge_weight :: Double
  77                  , edge_id     :: Text
  78                  }
  79   deriving (Show, Generic)
  80 $(deriveJSON (unPrefix "edge_") ''Edge)
  81 instance ToSchema Edge where
  82   declareNamedSchema =
  83     genericDeclareNamedSchema
  84       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
  85
  86 ---------------------------------------------------------------
  87 data LegendField = LegendField { _lf_id :: Int
  88                                , _lf_color :: Text
  89                                , _lf_label :: Text
  90    } deriving (Show, Generic)
  91 $(deriveJSON (unPrefix "_lf_") ''LegendField)
  92
  93 instance ToSchema LegendField where
  94   declareNamedSchema =
  95     genericDeclareNamedSchema
  96       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
  97
  98 makeLenses ''LegendField
  99 --
 100 data GraphMetadata = GraphMetadata { _gm_title    :: Text   -- title of the graph
 101                                    , _gm_corpusId :: [Int]  -- we can map with different corpus
 102                                    , _gm_legend :: [LegendField] -- legend of the Graph
 103                                    }
 104   deriving (Show, Generic)
 105 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
 106 instance ToSchema GraphMetadata where
 107   declareNamedSchema =
 108     genericDeclareNamedSchema
 109       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
 110 makeLenses ''GraphMetadata
 111
 112
 113 data Graph = Graph { _graph_nodes :: [Node]
 114                    , _graph_edges :: [Edge]
 115                    , _graph_metadata :: Maybe GraphMetadata
 116                    }
 117   deriving (Show, Generic)
 118 $(deriveJSON (unPrefix "_graph_") ''Graph)
 119 makeLenses ''Graph
 120
 121 instance ToSchema Graph where
 122   declareNamedSchema =
 123     genericDeclareNamedSchema
 124       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 7 fieldLabel}
 125
 126
 127 defaultGraph :: Graph
 128 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}
 129
 130 -- | Intances for the mack
 131 instance Arbitrary Graph where
 132   arbitrary = elements $ [defaultGraph]
 133
 134
 135 -----------------------------------------------------------
 136 -- V3 Gargantext Version
 137
 138 data AttributesV3 = AttributesV3 { cl :: Int }
 139   deriving (Show, Generic)
 140 $(deriveJSON (unPrefix "") ''AttributesV3)
 141
 142 data NodeV3 = NodeV3 { no_id :: Int
 143                    , no_at :: AttributesV3
 144                    , no_s :: Int
 145                    , no_lb :: Text
 146                    }
 147   deriving (Show, Generic)
 148 $(deriveJSON (unPrefix "no_") ''NodeV3)
 149
 150 data EdgeV3 = EdgeV3 { eo_s :: Int
 151                  , eo_t :: Int
 152                  , eo_w :: Text
 153                  }
 154   deriving (Show, Generic)
 155 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
 156
 157 data GraphV3 = GraphV3 {
 158                            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