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