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_x_coord :: Double
  53                  , node_y_coord :: Double
  54                  , node_attributes :: Attributes
  55                  }
  56   deriving (Show, Generic)
  57 $(deriveJSON (unPrefix "node_") ''Node)
  58 instance ToSchema Node where
  59   declareNamedSchema =
  60     genericDeclareNamedSchema
  61       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
  62
  63
  64 data Edge = Edge { edge_source :: Text
  65                  , edge_target :: Text
  66                  , edge_weight :: Double
  67                  , edge_id     :: Text
  68                  }
  69   deriving (Show, Generic)
  70 $(deriveJSON (unPrefix "edge_") ''Edge)
  71 instance ToSchema Edge where
  72   declareNamedSchema =
  73     genericDeclareNamedSchema
  74       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
  75
  76 ---------------------------------------------------------------
  77 data LegendField = LegendField { _lf_id :: Int
  78                                , _lf_color :: Text
  79                                , _lf_label :: Text
  80    } deriving (Show, Generic)
  81 $(deriveJSON (unPrefix "_lf_") ''LegendField)
  82
  83 instance ToSchema LegendField where
  84   declareNamedSchema =
  85     genericDeclareNamedSchema
  86       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
  87
  88 makeLenses ''LegendField
  89 --
  90 data GraphMetadata = GraphMetadata { _gm_title    :: Text   -- title of the graph
  91                                    , _gm_corpusId :: [NodeId]  -- we can map with different corpus
  92                                    , _gm_legend :: [LegendField] -- legend of the Graph
  93                                    }
  94   deriving (Show, Generic)
  95 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
  96 instance ToSchema GraphMetadata where
  97   declareNamedSchema =
  98     genericDeclareNamedSchema
  99       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
 100 makeLenses ''GraphMetadata
 101
 102
 103 data Graph = Graph { _graph_nodes :: [Node]
 104                    , _graph_edges :: [Edge]
 105                    , _graph_metadata :: Maybe GraphMetadata
 106                    }
 107   deriving (Show, Generic)
 108 $(deriveJSON (unPrefix "_graph_") ''Graph)
 109 makeLenses ''Graph
 110
 111 instance ToSchema Graph where
 112   declareNamedSchema =
 113     genericDeclareNamedSchema
 114       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 7 fieldLabel}
 115
 116
 117 -- | Intances for the mack
 118 instance Arbitrary Graph where
 119   arbitrary = elements $ [defaultGraph]
 120
 121 defaultGraph :: Graph
 122 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_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}
 123
 124
 125 -----------------------------------------------------------
 126 -- V3 Gargantext Version
 127
 128 data AttributesV3 = AttributesV3 { cl :: Int }
 129   deriving (Show, Generic)
 130 $(deriveJSON (unPrefix "") ''AttributesV3)
 131
 132 data NodeV3 = NodeV3 { no_id :: Int
 133                      , no_at :: AttributesV3
 134                      , no_s  :: Int
 135                      , no_lb :: Text
 136                      }
 137   deriving (Show, Generic)
 138 $(deriveJSON (unPrefix "no_") ''NodeV3)
 139
 140 data EdgeV3 = EdgeV3 { eo_s :: Int
 141                      , eo_t :: Int
 142                      , eo_w :: Text
 143                      }
 144   deriving (Show, Generic)
 145 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
 146
 147 data GraphV3 = GraphV3 { go_links :: [EdgeV3]
 148                        , go_nodes :: [NodeV3]
 149                        }
 150   deriving (Show, Generic)
 151 $(deriveJSON (unPrefix "go_") ''GraphV3)
 152
 153 -----------------------------------------------------------
 154 -----------------------------------------------------------
 155
 156 graphV3ToGraph :: GraphV3 -> Graph
 157 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
 158   where
 159     nodeV32node :: NodeV3 -> Node
 160     nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
 161                 = Node no_s' Terms (cs $ show no_id') no_lb' 0 0 (Attributes cl')
 162
 163     linkV32edge :: Int -> EdgeV3 -> Edge
 164     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)
 165
 166
 167 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
 168 graphV3ToGraphWithFiles g1 g2 = do
 169   -- GraphV3 <- IO Fichier
 170   graph <- DBL.readFile g1
 171   let newGraph = case DA.decode graph :: Maybe GraphV3 of
 172         Nothing -> panic (T.pack "no graph")
 173         Just new -> new
 174
 175   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 176
 177 readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
 178 readGraphFromJson fp = do
 179   graph <- liftIO $ DBL.readFile fp
 180   pure $ DA.decode graph