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
  20 import Control.Lens (makeLenses)
  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 Database.PostgreSQL.Simple.FromField (FromField, fromField)
  26 import GHC.Generics (Generic)
  27 import GHC.IO (FilePath)
  28 import Gargantext.Core.Types (ListId)
  29 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
  30 import Gargantext.Database.Admin.Types.Hyperdata (Hyperdata)
  31 import Gargantext.Database.Admin.Types.Node (NodeId)
  32 import Gargantext.Viz.Graph.Distances (GraphMetric)
  33 import Gargantext.Database.Prelude (fromField')
  34 import Gargantext.Prelude
  35 import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
  36 import Test.QuickCheck (elements)
  37 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  38 import qualified Data.Aeson as DA
  39 import qualified Data.Text as T
  40 import qualified Text.Read as T
  41
  42
  43 data TypeNode = Terms | Unknown
  44   deriving (Show, Generic)
  45
  46 $(deriveJSON (unPrefix "") ''TypeNode)
  47 instance ToSchema TypeNode
  48
  49 data Attributes = Attributes { clust_default :: Int }
  50   deriving (Show, Generic)
  51 $(deriveJSON (unPrefix "") ''Attributes)
  52 instance ToSchema Attributes
  53
  54 data Node = Node { node_size  :: Int
  55                  , node_type  :: TypeNode -- TODO NgramsType | Person
  56                  , node_id    :: Text     -- TODO NgramId
  57                  , node_label :: Text
  58                  , node_x_coord :: Double
  59                  , node_y_coord :: Double
  60                  , node_attributes :: Attributes
  61                  }
  62   deriving (Show, Generic)
  63 $(deriveJSON (unPrefix "node_") ''Node)
  64 instance ToSchema Node where
  65   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
  66
  67
  68 data Edge = Edge { edge_source :: Text
  69                  , edge_target :: Text
  70                  , edge_weight :: Double
  71                  , edge_confluence :: Double
  72                  , edge_id     :: Text
  73                  }
  74   deriving (Show, Generic)
  75 $(deriveJSON (unPrefix "edge_") ''Edge)
  76 instance ToSchema Edge where
  77   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
  78
  79 ---------------------------------------------------------------
  80 data LegendField = LegendField { _lf_id :: Int
  81                                , _lf_color :: Text
  82                                , _lf_label :: Text
  83    } deriving (Show, Generic)
  84 $(deriveJSON (unPrefix "_lf_") ''LegendField)
  85
  86 instance ToSchema LegendField where
  87   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
  88
  89 makeLenses ''LegendField
  90 ---------------------------------------------------------------
  91 type Version = Int
  92 data ListForGraph =
  93   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 =
 105   GraphMetadata { _gm_title    :: Text          -- title of the graph
 106                 , _gm_metric   :: GraphMetric
 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 =
 169   HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
 170                  } deriving (Show, Generic)
 171 $(deriveJSON (unPrefix "") ''HyperdataGraph)
 172
 173 instance Hyperdata HyperdataGraph
 174 makeLenses ''HyperdataGraph
 175
 176 instance FromField HyperdataGraph
 177   where
 178     fromField = fromField'
 179
 180 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
 181   where
 182     queryRunnerColumnDefault = fieldQueryRunnerColumn
 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