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