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