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