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