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