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