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